home *** CD-ROM | disk | FTP | other *** search
/ BBS Toolkit / BBS Toolkit.iso / rbbs_pc / mpl17ds.zip / RBBSSUB4.BAS < prev    next >
BASIC Source File  |  1989-06-14  |  121KB  |  3,095 lines
  1. ' $linesize:132
  2. ' $title: 'RBBSSUB4.BAS CPC17-1D, Copyright 1986 - 89 by D. Thomas Mack'
  3. '  Copyright 1988 by D. Thomas Mack, all rights reserved.
  4. '  Name ...............: RBBSSUB4.BAS
  5. '  Written by .........: D. Thomas Mack
  6. '  First Released .....: September 18, 1988
  7. '  Subsequent Releases.: OCt 30 1988
  8. '  Copyright ..........: 1986, 1987, 1988
  9. '  Purpose.............: The Remote Bulletin Board System for the IBM PC,
  10. '                        RBBS-PC.BAS utilizes a lot of common subroutines.
  11. '                        Those that do not require error trapping are
  12. '                        incorporated within RBBSSUB2.BAS, RBBSSUB3.BAS,
  13. '                        RBBSSUB4.BAS and RBBSSUB5.BAS as separately
  14. '                        callable subroutines in order to free up as much
  15. '                        code as possible within the 64K code segment
  16. '                        used by RBBS-PC.BAS.
  17. '  Parameters..........: Most parameters are passed via a COMMON statement.
  18. '
  19. ' Subroutine  Line               Function of Subroutine
  20. '   Name     Number
  21. '  ANYBUT     59760   Determine where a "word" begins
  22. '  ASKUSERS   64005   Ask users questions based on a script and save answers
  23. '  ASKMORE    59854   Check whether screen full
  24. '  AUTOPAGE           Check whether to notify sysop caller is on
  25. ' BADFILECHAR 59800   Check file name for bad character
  26. '  BRACKET    59950   Puts strings around a substring
  27. '  BUFFILE    58400   Write a file to the user quickly
  28. '  BUFSTRNG   58300   Write a string with imbedded CR/LF to the user quickly
  29. '  CHKCOLOR   59900+  Highlighting based on search string
  30. '  CHKNARY    58190   Check for the occurance of a string in an array
  31. '  COLORDIR   59920   Adds colorization to FMS directory entry
  32. '  COLORPMT   59924+  Colorizes prompts
  33. '  COMPDATE   59200+  Produces a computational data from YY, MM, DD
  34. '  CONFMAIL   59854   Check conference mail waiting
  35. '  CONVDIRS   58950   Checks for U & A (shorthand) and converts appropriately
  36. '  CSTRDATE   59200   Compress date in string format to 2 characters
  37. '  EOFCOMM    60000   Determine whether any chars in comm port buffer
  38. '  EXPDATE    59854+  Calculate registration expiration date
  39. '  FAKEXRPT   62650   Write out file transfer report for protocols that don't
  40. '  FINDEND    58770   Find where a "word" ends
  41. '  FINDFILE   58790   Determine whether a file exists without opening it
  42. '  FMS        58200   Search the upload management system for entries
  43. '  GETALL     59780   Get list of all directories to display
  44. '  GETDIRS    58900   Prompts for directories for file list/new/search cmds
  45. '  GETMATTR   62530   Restore attributes of original message
  46. '  GETYMD     59200   Pulls YY, MM, or DD from a 2 byte stored date
  47. '  GSANDR     60100   Global search and replace
  48. '  LOGDOWN    59400   Records download in private directory
  49. '  MARKTIME   60200   Give visual feedback during lengthy process
  50. '  METAGSR    60102+  Meta statement global search and replace
  51. '  MIMPORT    59700   Allow local user to import a text file to a message
  52. '  MUZAK      59100   Play musical themes for different RBBS functions
  53. '  PERSFILE   59300   View and select personal files for downloading
  54. '  PROTOCOL   62600   Determine if external protocols are available
  55. '  PUTMATTR   62520   Save attributes of original message
  56. '  REMOVE     58210   Remove characters from within strings
  57. '  ROTORSDIR  58700   Searches for a file using list of subdirs
  58. '  RPTTIME    62530+  Report date/time and time on
  59. '  SETABORT   58750   Set time for a process to abort
  60. '  SETECHO    59600   Set RBBS properly for who is to echo
  61. '  SETHILITE  59900+  Set user preference on highlighting
  62. '  SMARTTXT   58250   Process SMART TEXT control strings
  63. '  SUBMENU    59500   Processes options that have sub-menus
  64. '  TIMEDOUT   63000   Write timed exit semaphore file
  65. '  TIMELOCK   60150   Check for TIME LOCK on certain features
  66. '  TRANSFER   62620   RBBS-PC support for external protocols for file transfer
  67. '  TOGGLE     57000   Toggles or views user options
  68. ' TWOBYTEDATE 59200   Reduces a data to 2 byte string for space compression
  69. '  USERCOLOR  59970   Lets user set color for text and whether bold
  70. '  USERFACE   59450   Processes programmable user interface
  71. '  VIEWARC    64600   Display .ARC file contents to user
  72. '  XFRETURN   62629   Private door exit routine
  73. '  WIPELINE   58800   Wipes away a line so next prints in its place
  74. '  WORDWRAP   59700+  Adjust a message --wrap linesand perserve paragraphs
  75. '
  76. '  $INCLUDE: 'RBBS-VAR.BAS'
  77. '
  78. ' $SUBTITLE: 'TOGGLE - Toggle User Preferences'
  79. ' $PAGE
  80. '
  81. '  SUBROUTINE NAME    -- TOGGLE
  82. '
  83. '  INPUT PARAMETERS   -- TOGGLE.OPTION      Option to toggle or view
  84. '                                           according to the following:
  85. '    TOGGLE.OPTION         PREFERENCE
  86. '   TOGGLE   VIEW
  87. '     1       -1           Autodownload
  88. '     2       -2           Bulletin review on logon
  89. '     3       -3           Case change
  90. '     4       -4           File review on logon
  91. '     5       -5           Highlight
  92. '     6       -6           Line feeds
  93. '     7       -7           Nulls
  94. '     8       -8           TurboKey
  95. '     9       -9           Expert
  96. '    10      -10           Bell
  97. '
  98. '  OUTPUT PARAMETERS  -- SUBROUTINE.PARAMETER   passed from TPUT
  99. '
  100. '  SUBROUTINE PURPOSE -- Sets or views any single user preference value
  101. '
  102.       SUB TOGGLE (TOGGLE.OPTION) STATIC
  103. 57000 SUBROUTINE.PARAMETER = 0
  104.       IF TOGGLE.OPTION < 0 THEN _
  105.          GOTO 57005
  106.       ON TOGGLE.OPTION GOSUB _
  107.          57010, _         'Autodownload
  108.          57120, _         'Bulletin review on logon
  109.          57260, _         'Case change
  110.          57150, _         'File review on logon
  111.          57040, _         'Highlight
  112.          57100, _         'Line feeds
  113.          57210, _         'Nulls
  114.          57230, _         'TurboKey
  115.          57190, _         'Expert
  116.          57170            'Bell
  117.       EXIT SUB
  118. 57005 CALL ASKMORE ("",TRUE,TRUE,X,TRUE)
  119.       ON -TOGGLE.OPTION GOSUB _
  120.          57030, _         'Autodownload
  121.          57130, _         'Bulletin review on logon
  122.          57270, _         'Case change
  123.          57160, _         'File review on logon
  124.          57050, _         'Highlight
  125.          57110, _         'Line feeds
  126.          57220, _         'Nulls
  127.          57240, _         'TurboKey
  128.          57200, _         'Expert
  129.          57180            'Bell
  130.       EXIT SUB
  131. 57010 'IF AUTODOWNLOAD.DESIRED THEN _
  132.       '   GOTO 57020
  133.       'IF NOT AUTODOWNLOAD.VERIFIED THEN _
  134.       '   CALL TESTUSER
  135.       IF NOT AUTODOWNLOAD.AVAILABLE THEN _
  136.          CALL QTPUT (" AUTODOWNLOAD not supported,use a BATCH Protocol",1) : _
  137.          AUTODOWNLOAD.DESIRED = TRUE
  138. 57020 AUTODOWNLOAD.DESIRED = FALSE   'NOT AUTODOWNLOAD.DESIRED
  139. 57030 A$ ="" ' FG.1$+"Autodownload " + FNOFFON$(AUTODOWNLOAD.DESIRED)+EMPHASIZE.OFF$
  140.      CALL QTPUT (A$,1)
  141.      RETURN
  142. 57040 IF EMPHASIZE.ON.DEF$ = "" THEN _
  143.         CALL QTPUT ("Highlighting unavailable",1) : _
  144.         RETURN
  145.      CALL SETHILITE (NOT HIGHLIGHT.OFF)
  146.      IF HIGHLIGHT.OFF THEN _
  147.         CALL QTPUT (COLOR.RESET$,0)
  148.      GOSUB 57050
  149.      CALL USERCOLOR
  150.      RETURN
  151. 57050 IF EMPHASIZE.ON$ <> "" THEN _
  152.         EMPHASIZE.OFF$ = ESCAPE$ + "[" + BOLD.TEXT$ + _
  153.         ";40;" + MID$(STR$(USER.TEXT.COLOR),2) + "m"
  154.      CALL QTPUT (EMPHASIZE.ON$ + "Highlighting" + EMPHASIZE.OFF$ + _
  155.                  " " + FNOFFON$(NOT HIGHLIGHT.OFF),1)
  156.      RETURN
  157. 57100 LINE.FEEDS = NOT LINE.FEEDS
  158.       IF LOCAL.USER THEN _
  159.          LINE.FEEDS = TRUE
  160. 57110 CALL QTPUT("Line Feeds " + FNOFFON$(LINE.FEEDS),1)
  161.       CALL SETCRLF
  162.       RETURN
  163. 57120 CHECK.BULLETIN.LOGON = NOT CHECK.BULLETIN.LOGON
  164. 57130 A$ = CX$(2)+MID$("SKIP CHECK",1 -5 * CHECK.BULLETIN.LOGON,5) + _
  165.            " old BULLETINS in logon"
  166.       CALL QTPUT (A$,1)
  167.       RETURN
  168. 57150 SKIP.FILES.LOGON = NOT SKIP.FILES.LOGON
  169. 57160 A$ = CX$(3)+MID$("CHECKSKIP",1 -5 * SKIP.FILES.LOGON,5) + _
  170.            " new files in logon"
  171.       CALL QTPUT (A$,1)
  172.       RETURN
  173. 57170 PROMPT.BELL = NOT PROMPT.BELL
  174. 57180 A$ = CX$(4)+"Prompt Bell " + FNOFFON$(PROMPT.BELL)
  175.       CALL QTPUT (A$,1)
  176.       RETURN
  177. 57190 EXPERT.USER = NOT EXPERT.USER
  178.       CALL SETEXPERT
  179. 57200 A$ = CX$(5)+MID$("NoviceExpert",1 -6 * EXPERT.USER,6)
  180.       CALL QTPUT (A$,1)
  181.       RETURN
  182. 57210 NULLS = NOT NULLS
  183.       NUL$ = MID$(STRING$(5,0),1, - 5 * NULLS)
  184.       CALL SETCRLF
  185. 57220 A$ = CX$(6)+"Nulls " + FNOFFON$(NULLS)
  186.       CALL QTPUT (A$,1)
  187.       RETURN
  188. 57230 TURBO.KEY.USER = NOT TURBO.KEY.USER
  189. 57240 CALL QTPUT (CX$(1)+"TurboKey " + FNOFFON$(TURBO.KEY.USER),1)
  190.       RETURN
  191. 57260 UPPER.CASE = NOT UPPER.CASE
  192. 57270 A$ = "UPPER CASE " + _
  193.             MID$("and lowerONLY",1 - 9 * UPPER.CASE,9)
  194.       CALL QTPUT (CX$(2)+A$+EMPHASIZE.OFF$,1)
  195. 57280 USE.TPUT = (UPPER.CASE OR XON.XOFF)
  196.       RETURN
  197.       END SUB
  198. '
  199. ' $SUBTITLE: 'CHKNARY - subroutine to check for a string in an array'
  200. ' $PAGE
  201. '
  202. '  SUBROUTINE NAME    -- CHKNARY
  203. '
  204. '  INPUT PARAMETERS   -- PARAMETER                      MEANING
  205. '                        ELEMENT$                THE STRING TO CHECK FOR
  206. '                        ARRAY$()                THE ARRAY TO BE SEARCHED
  207. '                        NUM.ENTRIES.TO.SEARCH   NUMBER OF ENTRIES WITHIN IN
  208. '                                                THE ARRAY TO BE SEARCHED
  209. '
  210. '  OUTPUT PARAMETERS  -- IS.IN.ARA               0 = STRING NOT FOUND IN THE
  211. '                                                    ARRAY SPECIFIED
  212. '                                                OTHERWISE IT IS THE NUMBER OF
  213. '                                                ELEMENT WITHIN THE ARRAY THAT
  214. '                                                WAS FOUND TO MATCH
  215. '
  216. '  SUBROUTINE PURPOSE -- SEARCH AN ARRAY FOR A SPECIFIED STRING AND, IF FOUND,
  217. '                        RETURN THE NUMBER OF THE ELEMENT THAT MATCHED.
  218. '
  219.       SUB CHKNARY (ELEMENT$,ARRAY$(1),NUM.ENTRIES.TO.SEARCH,IS.IN.ARA) STATIC
  220. 58190 IS.IN.ARA = 1
  221.       CALL ALLCAPS (ELEMENT$)
  222.       MAX.TRIES = NUM.ENTRIES.TO.SEARCH + 1
  223.       ARRAY$(MAX.TRIES) = ELEMENT$
  224.       WHILE ARRAY$(IS.IN.ARA) <> ELEMENT$
  225.          IS.IN.ARA = IS.IN.ARA + 1
  226.       WEND
  227.       IF IS.IN.ARA = MAX.TRIES THEN _
  228.          IS.IN.ARA = 0
  229.       END SUB
  230. ' $SUBTITLE: 'FMS - subroutine to search the upload management system'
  231. ' $PAGE
  232. '
  233. '  SUBROUTINE NAME    -- FMS
  234. '
  235. '  INPUT PARAMETERS   -- PARAMETER                      MEANING
  236. '                        DIR.TO.SEARCH$          RBBS-PC "DIR" CATEGORY TO LOOK
  237. '                                                FOR
  238. '                        SEARCH.STRING$          STRING TO SEARCH FOR
  239. '                        SEARCH.DATE$            DATE TO SEARCH FOR
  240. '                        CATEGORY.NAME$()
  241. '                        CATEGORY.CODE$()
  242. '                        CATEGORY.DESC$()
  243. '                        CAT.FOUND
  244. '                        NUM.CATEGORIES
  245. '
  246. '  OUTPUT PARAMETERS  -- PROCESSED.IN.FMS
  247. '                        DOWNLOAD.FLAG
  248. '
  249. '  SUBROUTINE PURPOSE -- TO SEARCH THE UPLOAD MANAGMENT SYSTEM AND DISPLAY THE
  250. '                        FILES BEING SEARCHED FOR AS WELL AS THE CATEGORY DE-
  251. '                        SCRIPTIONS
  252. '
  253.       SUB FMS (DIR.TO.SEARCH$,SEARCH.STRING$,SEARCH.DATE$, _
  254.                PROCESSED.IN.FMS,CATEGORY.NAME$(1),CATEGORY.CODE$(1), _
  255.                CATEGORY.DESC$(1),DOWNLOAD.FLAG,CAT.FOUND,ABORT.INDEX) STATIC
  256. 58200 DOWNLOAD.FLAG = 0
  257.       CALL CHKNARY (DIR.TO.SEARCH$,CATEGORY.NAME$(),NUM.CATEGORIES,CAT.FOUND)
  258.       PROCESSED.IN.FMS = PROCESSED.IN.FMS OR (CAT.FOUND > 0)
  259.       IF PROCESSED.IN.FMS THEN _
  260.          SUBROUTINE.PARAMETER = 5 : _
  261.          GOSUB 58202 : _
  262.          A$ = "Scanning directory " + _
  263.               DIR.TO.SEARCH$ + _
  264.               HDR$ + _
  265.               " - " + _
  266.               CATEGORY.DESC$(CAT.FOUND) : _
  267.          CALL TPUT : _
  268.          CAT$ = CATEGORY.CODE$(CAT.FOUND) : _
  269.          CALL DISUPDIR (CAT$,SEARCH.STRING$,SEARCH.DATE$,DOWNLOAD.FLAG,ABORT.INDEX)
  270.       EXIT SUB
  271. 58202 A$ = SEARCH.DATE$
  272.       IF LEN(A$) > 0 THEN _
  273.          A$ = MID$(A$,3) + LEFT$(A$,2)
  274.       HDR$ = " for " + _
  275.              SEARCH.STRING$ + _
  276.              A$
  277.       IF LEN(HDR$) < 6 THEN _
  278.          HDR$ = ""
  279.       RETURN
  280.       END SUB
  281. ' $SUBTITLE: 'REMOVE - subroutine to delete a string from within a string'
  282. ' $PAGE
  283. '
  284. '  SUBROUTINE NAME    -- REMOVE
  285. '
  286. '  INPUT PARAMETERS   -- PARAMETER                      MEANING
  287. '                        BADSTRING$              STRING CONTAINING CHARACTERS
  288. '                                                TO BE DELETED FROM "L$"
  289. '                        L$                      STRING TO BE ALTERED
  290. '
  291. '  OUTPUT PARAMETERS  -- L$                      WITH THE CHARACTERS IN
  292. '                                                "BADSTRING#" DELETED FROM IT
  293. '
  294. '  SUBROUTINE PURPOSE -- TO REMOVE ALL INSTANCES OF THE CHARACTERS IN
  295. '                        "BADSTRING$" FROM "L$"
  296. '
  297.       SUB REMOVE (L$,BADSTRNG$) STATIC
  298. 58210 J = 0
  299.       FOR I=1 TO LEN(L$)
  300.          IF INSTR(BADSTRNG$,MID$(L$,I,1)) = 0 THEN _
  301.             J = J + 1 : _
  302.             MID$(L$,J,1) = MID$(L$,I,1)
  303.       NEXT I
  304.       L$ = LEFT$(L$,J)
  305.       END SUB
  306. '
  307. ' $SUBTITLE: 'SMARTTXT - smart text substitution'
  308. ' $PAGE
  309. '
  310. '  SUBROUTINE NAME    -- SMARTTXT   (WRITTEN BY DOUG AZZARITO)
  311. '
  312. '  INPUT PARAMETERS   -- STRNG.WORK$        string to scan for Smart Text
  313. '                        CR.FOUND           Does this line contain a CR?
  314. '                        SMART.TEXT         Smart Text control code
  315. '
  316. '  OUTPUT PARAMETERS  -- STRNG.WORK$        Input string with Smart replaced
  317. '
  318. '  SUBROUTINE PURPOSE -- Smart Text allows control strings in text files
  319. '                        to be replaced at runtime with user info or other
  320. '                        data.  The Smart Text control code is a 1-byte
  321. '                        code (configurable) with a 2-byte action code.
  322. '
  323.       SUB SMARTTXT (STRNG.WORK$, CR.FOUND) STATIC
  324. 58250 IF SMART.CARRY$<>"" THEN _
  325.          STRNG.WORK$ = SMART.CARRY$+STRNG.WORK$
  326.       INDEX = INSTR(STRNG.WORK$, SMART.TEXT$)
  327.       WHILE INDEX > 0 AND INDEX < LEN(STRNG.WORK$)-1
  328.          IF INSTR(MID$(STRNG.WORK$, INDEX+1,2)," ") THEN _
  329.             SMART.ACT = 0 _
  330.          ELSE _
  331.             SMART.ACT = INSTR(SMART.TABLE$, MID$(STRNG.WORK$, INDEX+1, 2))
  332.          IF SMART.ACT > 0 THEN _
  333.             SMART.ACT = (SMART.ACT+2)/3 : _
  334.             ON SMART.ACT GOSUB 58260, 58261, 58262, 58263, 58264, 58265, _
  335.                          58266, 58267, 58268, 58269, 58270, _
  336.                          58271, 58272, 58273, 58274, 58275, _
  337.                          58276, 58277, 58278, 58279, 58280, _
  338.                          58281, 58282, 58283, 58284, 58285 : _  'BK012901
  339.             CALL TRIM(SMART.HOLD$) : _                          'BK012901
  340.             STRNG.WORK$ = LEFT$(STRNG.WORK$, INDEX-1) + SMART.HOLD$ + _
  341.                MID$(STRNG.WORK$,INDEX+3)
  342.          INDEX = INSTR(INDEX+1, STRNG.WORK$, CHR$(SMART.TEXT))
  343.       WEND
  344.       IF INDEX AND (INDEX > LEN(STRNG.WORK$)-2) AND NOT CR.FOUND THEN _
  345.          SMART.CARRY$ = MID$(STRNG.WORK$,INDEX) : _
  346.          STRNG.WORK$ = LEFT$(STRNG.WORK$,INDEX-1) : _
  347.       ELSE _
  348.          SMART.CARRY$ = ""
  349.       EXIT SUB
  350. 58260 LINES.PRINTED = 0                     ' CS (Clear screen line count reset)
  351.       SMART.HOLD$ = ""
  352.       RETURN
  353. 58261 LINES.PRINTED = PAGE.LENGTH           ' PB Page Break
  354.       IF NON.STOP THEN _                    ' force a 1-time pause
  355.          ONE.STOP = TRUE : _                ' if NON STOP is on
  356.          NON.STOP = FALSE
  357.       SMART.HOLD$ = ""
  358.       FORCE.KEYBOARD = TRUE
  359.       RETURN
  360. 58262 NON.STOP = TRUE                       ' NS Non-stop
  361.       SMART.HOLD$ = ""
  362.       RETURN
  363. 58263 IF GLOBAL.SYSOP THEN _       'FN First Name                    ' KG012603
  364.          SMART.HOLD$ = ORIG.SYSOP.FN$ _                              ' KG012603
  365.       ELSE SMART.HOLD$ = FIRST.NAME$                                 ' KG012603
  366.       RETURN
  367. 58264 IF GLOBAL.SYSOP THEN _       'LN User's LAST name              ' KG012603
  368.          SMART.HOLD$ = ORIG.SYSOP.LN$ _                              ' KG012603
  369.       ELSE SMART.HOLD$ = LAST.NAME$                                  ' KG012603
  370.       RETURN
  371. 58265 SMART.HOLD$ = MID$(STR$(USER.SECURITY.LEVEL),2)   ' SL Security level
  372.       RETURN
  373. 58266 SMART.HOLD$ = DATE$
  374.       RETURN
  375. 58267 SUBROUTINE.PARAMETER = 2                                       ' KG111105
  376.       CALL AMORPM
  377.       SMART.HOLD$ = TIM$
  378.       RETURN
  379. 58268 CALL TIMEREMAIN(TIME.REMAINING!)      ' TR Time remaining (in mins)
  380.       SMART.HOLD$ = MID$(STR$(INT(TIME.REMAINING!)),2)
  381.       RETURN
  382. 58269 CALL TIMEREMAIN(TIME.REMAINING!)      ' TE Time elapsed (mm:ss)
  383.       SMART.HOLD$ = MID$(STR$(INT(TCA!/60)),2)+":"+ MID$(STR$((TCA! MOD 60)+100),3)
  384.       RETURN
  385. 58270 SMART.HOLD$ = MID$(STR$(INT((TIME.LOCK.SET+0.5)/60)),2) ' TL - Time Lock period
  386.       SMART.HOLD$ = SMART.HOLD$ + ":"+ MID$(STR$((TIME.LOCK.SET MOD 60)+100),3)
  387.       RETURN
  388. 58271 SMART.HOLD$ = MID$(STR$(DAYS.IN.REGISTRATION.PERIOD),2)
  389.       RETURN                                ' RP Registration Length
  390. 58272 SMART.HOLD$ = MID$(STR$(REG.DAYS.REMAINING),2)
  391.       RETURN                                ' RR Registration Remaining
  392. 58273 SMART.HOLD$ = CITY.STATE$             ' CT Users CITY & STATE
  393.       RETURN
  394. 58274 SMART.HOLD$ = FG.1$                   ' C1 Color 1
  395.       RETURN
  396. 58275 SMART.HOLD$ = FG.2$                   ' C2 Color 2
  397.       RETURN
  398. 58276 SMART.HOLD$ = FG.3$                   ' C3 Color 3
  399.       RETURN
  400. 58277 SMART.HOLD$ = FG.4$                   ' C4 Color 4
  401.       RETURN
  402. 58278 SMART.HOLD$ = EMPHASIZE.OFF$          ' C0 Reset color
  403.       RETURN
  404. 58279 SMART.HOLD$ = MID$(STR$(INT(DL.TODAY!)),2)
  405.       RETURN                                ' DD files Dnlded TODAY
  406. 58280 SMART.HOLD$ = MID$(STR$(INT(BYTES.TODAY!)),2)
  407.       RETURN                                ' BD Bytes Dnlded TODAY
  408. 58281 SMART.HOLD$ = MID$(STR$(INT(DLBYTES!)),2)
  409.       RETURN                                ' DB Download Bytes
  410. 58282 SMART.HOLD$ = MID$(STR$(INT(ULBYTES!)),2)
  411.       RETURN                                ' UB Upload Bytes
  412. 58283 SMART.HOLD$ = MID$(STR$(DOWNLOADS),2) ' DL Number of Dnlds
  413.       RETURN
  414. 58284 SMART.HOLD$ = MID$(STR$(UPLOADS),2)   ' UL Number of Uplds
  415.       RETURN
  416. 58285 SMART.HOLD$ = STR$(LIMIT.MINUTES.PER.SESSION!)        'BK012901
  417.       RETURN                    ' NT Time for Netmail  'BK012901
  418.       END SUB
  419. '
  420. ' $SUBTITLE: 'BUFSTRNG - subroutine to write a string with imbedded CR/LF'
  421. ' $PAGE
  422. '
  423. '  SUBROUTINE NAME    -- BUFSTRNG
  424. '
  425. '  INPUT PARAMETERS   -- PARAMETER                      MEANING
  426. '                        STRNG$                  STRING TO BE WRITTEN OUT
  427. '                        DATA.SIZE               LENGTH OF STRING - # LEFT
  428. '                                                    CHARS TO OUTPUT
  429. '
  430. '  OUTPUT PARAMETERS  -- STRNG$                  IS WRITTEN TO THE USER
  431. '
  432. '  SUBROUTINE PURPOSE -- TO SEARCH THE STRING, STRNG$, FOR IMBEDDED CARRIAGE
  433. '                        RETURNS AND LINE FEEDS AND WRITE OUT EACH LINE WITH
  434. '                        THE APPROPRIATE SUBSTITUTION (CR/LF IF TO THE LOCAL
  435. '                        SCREEN OR CR/NULLS/LF IF TO THE COMMUNICATIONS PORT).
  436. '
  437. 58300 SUB BUFSTRNG (STRNG$,PASSED.DATA.SIZE,ABORT.INDEX) STATIC
  438.       L = LEN(STRNG$)
  439.       IF PASSED.DATA.SIZE < L THEN _
  440.          L = PASSED.DATA.SIZE
  441.       IF L < 1 THEN _
  442.          EXIT SUB
  443.       FF = PAGE.LENGTH - 1
  444.       START.BYTE = 1
  445.       IF CARRY.OVER THEN _
  446.          IF ASC(STRNG$) = 10 THEN _
  447.             START.BYTE = 2 : _
  448.             CALL SKIPLINE (1)
  449.       CARRY.OVER = (MID$(STRNG$,L,1) = CARRIAGE.RETURN$)
  450.       L = L + CARRY.OVER
  451. 58301 CRAT = INSTR(START.BYTE,STRNG$,CARRIAGE.RETURN$)
  452.       IF CRAT > 0 AND CRAT < L THEN _
  453.          CR.FOUND = (MID$(STRNG$,CRAT + 1,1) = LINE.FEED$) _
  454.       ELSE CR.FOUND = FALSE
  455.       EOL.LEN = -2 * CR.FOUND
  456.       IF CR.FOUND THEN _
  457.          EOD = CRAT _
  458.       ELSE EOD = L + 1
  459.       NUM.BYTES = EOD - START.BYTE
  460.       STRNG.WORK$ = MID$(STRNG$,START.BYTE,NUM.BYTES)
  461.       IF NOT DELETE.INVALID THEN _
  462.          GOTO 58304
  463.       INDEX = INSTR(STRNG.WORK$,"[")
  464.       J = LEN(STRNG.WORK$) - 1
  465.       WHILE INDEX > 0 AND INDEX < J
  466.          IF MID$(STRNG.WORK$,INDEX + 2,1) = "]" THEN _
  467.             IF INSTR (INVALID.OPTS$,MID$(STRNG.WORK$,INDEX + 1,1)) THEN _
  468.                MID$(STRNG.WORK$,INDEX + 1,1) = "*"
  469.          INDEX = INSTR(INDEX + 1,STRNG.WORK$,"[")
  470.       WEND
  471. 58304 IF SMART.TEXT THEN _
  472.          CALL SMARTTXT (STRNG.WORK$, CR.FOUND)
  473.       CALL QTPUT (STRNG.WORK$, - (CR.FOUND))
  474.       IF RET THEN _
  475.          EXIT SUB
  476.       IF LINES.PRINTED < FF THEN _
  477.          GOTO 58305
  478.       CALL CHKTREMAIN (TIME.REMAINING!)
  479.       CALL CARRIER
  480.       IF SUBROUTINE.PARAMETER = -1 THEN _
  481.          EXIT SUB
  482.       IF NON.STOP THEN _
  483.          GOTO 58305
  484.       CALL ASKMORE ("",TRUE,FALSE,ABORT.INDEX,STOP.INTERRUPTS)
  485.       IF NO THEN _
  486.          RET = TRUE : _
  487.          EXIT SUB
  488. 58305 START.BYTE = EOD + EOL.LEN
  489.       IF START.BYTE <= L THEN _
  490.          GOTO 58301
  491.       END SUB
  492. ' $SUBTITLE: 'BUFFILE - subroutine to write a sequential file to the user'
  493. ' $PAGE
  494. '
  495. '  SUBROUTINE NAME    -- BUFFILE
  496. '
  497. '  INPUT PARAMETERS   -- PARAMETER                      MEANING
  498. '                        FILENAME$               NAME OF THE FILE TO WRITE TO
  499. '                                                OUT TO THE USER
  500. '
  501. '  OUTPUT PARAMETERS  -- NONE                    FILE IS WRITTEN TO THE USER
  502. '
  503. '  SUBROUTINE PURPOSE -- TO DISPLAY A SEQUENTIAL FILE TO THE USER
  504. '
  505. 58400 SUB BUFFILE (FILNAME$,ABORT.INDEX) STATIC
  506.       CALL FINDIT (FILNAME$)
  507.       IF NOT OK THEN _
  508.          EXIT SUB
  509.       NO = FALSE
  510.       CALL OPENRSEQ (FILNAME$,NUM.RECS,LEN.LAST.REC,BUFFER.SIZE)
  511.       DATA.SIZE = BUFFER.SIZE
  512.       FIELD 2, DATA.SIZE AS SEQ.REC$
  513.       NON.STOP = NON.STOP OR (PAGE.LENGTH < 1)
  514.       IF NOT STOP.INTERRUPTS THEN _
  515.          IF NOT CONCAT.FILES THEN _
  516.             IF NOT NON.STOP THEN _
  517.                A$ = "* Ctrl-K(^K) / ^X aborts. ^S suspends ^Q resumes *" : _
  518.                SUBROUTINE.PARAMETER = 2 : _
  519.                CALL TPUT
  520.       TU = 0
  521. 58405 TU = TU + 1
  522.       IF TU < NUM.RECS THEN _
  523.          GET 2,TU _
  524.       ELSE IF TU = NUM.RECS THEN _
  525.               GET 2,TU : _
  526.               X = INSTR(SEQ.REC$,CHR$(26)) : _
  527.               IF X = 0 OR X > LEN.LAST.REC THEN _
  528.                  DATA.SIZE = LEN.LAST.REC _
  529.               ELSE DATA.SIZE = X - 1 _
  530.            ELSE GOTO 58419
  531.       IF LOCAL.USER THEN _
  532.          GOTO 58406
  533.       CALL EOFCOMM (CHAR%)
  534.       IF CHAR% <> -1 THEN _
  535.          GOTO 58407            ' comm port input
  536. 58406 KEYBOARD.STACK$ = INKEY$
  537.       IF KEYBOARD.STACK$ = "" THEN _  ' no keyboard input
  538.          CALL BUFSTRNG (SEQ.REC$,DATA.SIZE,ABORT.INDEX) : _
  539.          GOTO 58408
  540. 58407 A$ = LEFT$(SEQ.REC$,DATA.SIZE)  ' process comm/keyboard
  541.       SUBROUTINE.PARAMETER = 4
  542.       CALL TPUT
  543. 58408 IF SUBROUTINE.PARAMETER <> -1 AND NOT RET THEN _
  544.          GOTO 58405
  545. 58419 CLOSE 2
  546.       BYPASS.TIME.CHECK = FALSE
  547.       STOP.INTERRUPTS = FALSE
  548.       CALL QTPUT (EMPHASIZE.OFF$,0)
  549.       END SUB
  550. ' $SUBTITLE: 'FINDLAST - subroutine to find last occurence of a string'
  551. ' $PAGE
  552. '
  553. '  SUBROUTINE NAME    -- FINDLAST
  554. '
  555. '  INPUT PARAMETERS   -- PARAMETER             MEANING
  556. '                        LOOK.IN$           STRING TO LOOK INTO
  557. '                        LOOK.FOR$          STRING TO SEARCH FOR
  558. '
  559. '  OUTPUT PARAMETERS  -- WHERE.FOUND        POSITION IN LOOK.IN$ THAT
  560. '                                            LOOK.FOR$ FOUND
  561. '                        NUM.FINDS          HOW MANY OCCURENCES IN LOOK.IN$
  562. '
  563. '  SUBROUTINE PURPOSE -- FINDS LAST OCCURANCE OF LOOK.FOR$ IN LOOK.IN$ AND
  564. '                        RETURNS COUNT OF # OF OCCURANCES.  IF NONE FOUND,
  565. '                        BOTH RETURNED PARAMETERS ARE SET TO 0.
  566. '
  567.       SUB FINDLAST (LOOK.IN$,LOOK.FOR$,WHERE.FOUND,NUM.FINDS) STATIC
  568. 58600 WHERE.FOUND = INSTR(LOOK.IN$,LOOK.FOR$)
  569.       NUM.FINDS = -(WHERE.FOUND > 0)
  570.       NEXT.FOUND = INSTR(WHERE.FOUND + 1,LOOK.IN$,LOOK.FOR$)
  571.       WHILE NEXT.FOUND > 0
  572.          NUM.FINDS = NUM.FINDS + 1
  573.          WHERE.FOUND = NEXT.FOUND                                    ' FORMAT
  574.          NEXT.FOUND = INSTR(WHERE.FOUND + 1,LOOK.IN$,LOOK.FOR$)
  575.       WEND
  576.       END SUB
  577. ' $SUBTITLE: 'ROTORSDIR - search thru a list of subdirs for a file'
  578. ' $PAGE
  579. '
  580. '  SUBROUTINE NAME    -- ROTORSDIR
  581. '
  582. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  583. '                        FILNAME$                  FILE NAME TO LOOK FOR
  584. '                        SDIR.ARA                  ARRAY OF SUBDIRECTORIES
  585. '                        MAX.SEARCH                MAX # OF SUBDIRECTORIES
  586. '                        MARK.TIME                 WHETHER TO MARK TIME
  587. '
  588. '   OUTPUT PARAMETERS -- FNAME$                    ADD SUBDIRECTORY TO THE
  589. '                                                  FILE NAME IF FOUND.  OTHER-
  590. '                                                  WISE DON'T.
  591. '                        OK                        TRUE IF FILE WAS FOUND
  592. '
  593. '  SUBROUTINE PURPOSE -- HUNT THROUGH A LIST OF SUBDIRECTORIES TO DETERMINE
  594. '                        IF A FILE IS IN ANY OF THEM.  IF FILE IS FOUND, OPEN
  595. '                        THE FILE AS FILE #2, ADD THE DRIVE/PATH TO THE FILE
  596. '                        NAME, AND SETS OK TO TRUE.  IF FILE ISN'T FOUND, SET
  597. '                        FILE NAME TO THE LAST SUBDIRECTORY SEARCHED -- WHICH
  598. '                        SHOULD BE THE UPLOAD SUBDIRECTORY.
  599. '
  600. '                        IF THE LIBRARY MENU IS SELECTED (MENU.INDEX = 6), THEN
  601. '                        ONLY 2 SUBDIRECTORIES ARE SEARCHED. THE FIRST BEING
  602. '                        THE WORK DISK AND THE SECOND BEING THE SELECTED
  603. '                        LIBRARY DISK.
  604. '
  605.       SUB ROTORSDIR (FILNAME$,SDIR.ARA$(1),MAX.SEARCH,MARK.TIME) STATIC
  606. 58700 OK = FALSE
  607.       IF MARK.TIME THEN _
  608.          CALL QTPUT ("Searching for "+FILNAME$,0)
  609.       IF MENU.INDEX = 6 THEN _
  610.          GOTO 58705
  611.       NUM.SEARCH = 1
  612.       X = 0
  613.       WHILE (NOT OK) AND NUM.SEARCH <= MAX.SEARCH AND _
  614.          SDIR.ARA$(NUM.SEARCH) <> ""
  615.          IF MARK.TIME THEN _
  616.             CALL MARKTIME (X)
  617.          X$ = SDIR.ARA$(NUM.SEARCH) + _
  618.               FILNAME$
  619.          CALL FINDIT (X$)
  620.          NUM.SEARCH = NUM.SEARCH + 1
  621.       WEND
  622.       GOTO 58710
  623. 58705 X$ = LIBRARY.WORK.DISK.PATH$ + _
  624.            FILNAME$
  625.       CALL FINDIT (X$)
  626.       IF OK THEN _
  627.          GOTO 58710
  628.       X$ = LIBRARY.DRIVE$ + _
  629.            FILNAME$
  630.       CALL FINDIT (X$)
  631. 58710 FILNAME$ = X$
  632.       CALL SKIPLINE (-MARK.TIME)
  633.       END SUB
  634. ' $SUBTITLE: 'WIPELINE - Wipe away a line so next overprints'
  635. ' $PAGE
  636. '
  637. '  SUBROUTINE NAME    -- WIPELINE
  638. '
  639. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  640. '                            CARRIAGE.RETURN$
  641. '                            CHARS.TO.WIPE            # OF CHARACTERS TO BLANK
  642. '                            NULLS
  643. '
  644. '   OUTPUT PARAMETERS -- NONE
  645. '
  646. '  SUBROUTINE PURPOSE -- WIPE AWAY A LINE AND LEAVE CURSOR AT BEGINNING OF THE
  647. '                        SAME LINE SO THAT THE NEXT LINE WILL PRINT IN ITS
  648. '                        PLACE
  649. '
  650.       SUB WIPELINE (CHARS.TO.WIPE) STATIC
  651. 58800 IF NULLS OR CHARS.TO.WIPE > 79 THEN _
  652.          CALL SKIPLINE (1) : _
  653.          EXIT SUB
  654.       IF NOT LOCAL.USER THEN _
  655.          STRNG$ = CARRIAGE.RETURN$ + SPACE$(CHARS.TO.WIPE) + CARRIAGE.RETURN$ : _
  656.          IF FOSSIL THEN _
  657.             BYTES% = LEN(STRNG$) : _
  658.             CALL FOSWRITE(COMPORT%,BYTES%,STRNG$) _
  659.          ELSE PRINT #3,STRNG$
  660.       IF SNOOP THEN _
  661.          LOCATE ,1 :  _
  662.          CALL LPRNT(SPACE$(CHARS.TO.WIPE),0) : _
  663.          LOCATE ,1
  664.       IF F7.MESSAGE$ = "" OR _
  665.          F7.MESSAGE$ = "NONE" OR _
  666.          NOT SYSOP.NEXT THEN _
  667.          EXIT SUB
  668.       BYPASS.TIME.CHECK = TRUE
  669.       CALL BUFFILE (F7.MESSAGE$,X)
  670.       END SUB
  671. ' $SUBTITLE: 'GETDIRS -- Prompt for directories to search'
  672. ' $PAGE
  673. '
  674. '  SUBROUTINE NAME    -- GETDIRS
  675. '
  676. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  677. '                            DIR.PROMPT$             BASE OF DIRECTORY PROMPT
  678. '                            SHOW.HELP               Whether to display help
  679. '                                                    on entry
  680. '   OUTPUT PARAMETERS --     B$
  681. '                            Q
  682. '  SUBROUTINE PURPOSE -- Prompt for directories to search
  683. '
  684.       SUB GETDIRS (SHOW.HELP) STATIC
  685.       IF SHOW.HELP THEN _
  686.          GOTO 58902
  687. 58900 A$ = DIR.PROMPT$
  688.       SUBROUTINE.PARAMETER = 1
  689.       CALL TGET
  690.       IF Q = 0 OR SUBROUTINE.PARAMETER = -1 THEN _
  691.          EXIT SUB
  692.       CALL ALLCAPS (B$(1))
  693.       IF B$(1) = "Q" THEN _
  694.          Q = 0 : _
  695.          EXIT SUB
  696.       A = INSTR("E+.E-.E.L.H.?.",B$(1)+".")
  697.       IF A = 0 THEN _
  698.          EXIT SUB
  699.       IF A > 8 THEN _
  700.          GOTO 58901
  701.       IF A = 7 THEN _
  702.          EXTENDED.OFF = NOT EXTENDED.OFF _
  703.       ELSE EXTENDED.OFF = (A > 3)
  704.       CALL QTPUT (CX$(5)+"Extended directory display "+MID$("ON OFF",1-3*EXTENDED.OFF,3)+EMPHASIZE.OFF$,1)
  705.       GOTO 58900
  706. 58901 IF A = 9 AND Q > 1 THEN _
  707.          Q = Q - 1 : _
  708.          FOR B = 1 TO Q : _
  709.             B$(B) = B$(B + 1) : _
  710.          NEXT : _
  711.          EXIT SUB
  712. 58902 FILE.NAME$ = DIRECTORY.PATH$ + DIRECTORY.PREFIX$ + _
  713.                     "." + DIRECTORY.EXTENTION$
  714.       GDEFAULT$ = MID$(" GC",GR + 1, 1)
  715.       CALL GRAPHIC (GDEFAULT$)
  716.       CALL BUFFILE (FILE.NAME$,X)
  717.       GOTO 58900
  718.       END SUB
  719. '
  720. ' $SUBTITLE: 'CONVDIRS -- Converts coded response to right directory'
  721. ' $PAGE
  722. '
  723. '  SUBROUTINE NAME    -- CONVDIRS
  724. '
  725. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  726. '                            STRT               ELEMENT TO BEGIN WITH
  727. '                            B$                 ARRAY TO CONVERT
  728. '                            Q                  LAST ELEMENT TO CONFERT
  729. '
  730. '   OUTPUT PARAMETERS --     B$                 CONVERTED DIRECTORY LIST
  731. '
  732. '  SUBROUTINE PURPOSE -- LET THE USER PUT IN A SHORT STANDARD STRING FOR A
  733. '                        DIRECTORY
  734. '
  735. '
  736. 58950 SUB CONVDIRS (STRT) STATIC
  737.       FOR I=STRT TO Q
  738.          CALL ALLCAPS (B$(I))
  739.          IF B$(I)="U" THEN _
  740.             B$(I) = UPLOAD.DIR.CHECK$
  741.          IF B$(I) = "A" THEN _
  742.             B$(I) = "ALL"
  743.       NEXT
  744.       END SUB
  745. ' $SUBTITLE: 'TWOBYTEDATE -- subroutine to put date in two bytes'
  746. ' $PAGE
  747. '
  748. '  SUBROUTINE NAME    -- TWOBYTEDATE
  749. '
  750. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  751. '                             YY       FOUR DIGIT YEAR (I.E. 1987)
  752. '                             MM       MONTH
  753. '                             DD       DAY
  754. '                           RESULT$    LOCATION TO PLACE THE RESULT
  755. '
  756. '  OUTPUT PARAMETERS  -- RESULT$       TWO BYTE COMPRESSED DATE FOR USE IN
  757. '                                      A RANDOM RECORD
  758. '
  759. '  SUBROUTINE PURPOSE -- COMPRESS AN Y,M,D DATE INTO TWO CHARACTERS
  760.       SUB TWOBYTEDATE (YY,MM,DD,RESULT$) STATIC
  761. 59200 RESULT$ = CHR$(((YY - 1980) * 2) OR - ((MM AND 8) <> 0)) + _
  762.                 CHR$((MM AND NOT 8) * 32 + DD)
  763.       END SUB
  764. ' $SUBTITLE: 'CSTRDATE -- subroutine to Compress STRing DATE'
  765. ' $PAGE
  766. '
  767. '  SUBROUTINE NAME    -- CSTRDATE
  768. '
  769. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  770. '                            STRNG$   String Date (mm-dd-yyyy)
  771. '
  772. '  OUTPUT PARAMETERS  --    RESULT$    TWO BYTE COMPRESSED DATE FOR USE IN
  773. '                                      A RANDOM RECORD
  774. '
  775. '  SUBROUTINE PURPOSE -- COMPRESS AN 8-CHARACTER DATE INTO TWO CHARACTERS
  776.       SUB CSTRDATE (STRNG$,RESULT$) STATIC
  777.       IF LEN(STRNG$) < 8 THEN _
  778.          EXIT SUB
  779.       YY = VAL(MID$(STRNG$,7))
  780.       MM = VAL(STRNG$)
  781.       DD = VAL(MID$(STRNG$,4))
  782.       CALL TWOBYTEDATE (YY,MM,DD,RESULT$)
  783.       END SUB
  784. ' $SUBTITLE: 'UNCDATE -- subroutine to UNCompress DATE'
  785. ' $PAGE
  786. '
  787. '  SUBROUTINE NAME    -- UNCDATE
  788. '
  789. '  INPUT PARAMETERS   --   PARAMETER      MEANING
  790. '                        COMPRESSED.DATE$ Date in 2 byte compressed form
  791. '
  792. '  OUTPUT PARAMETERS  --     YY           Year of compressed date
  793. '                            MM           Month of compressed date
  794. '                            DD           Day of compressed date
  795. '                        DISPLAY.DATE$    8 char display date (mm-dd-yyyy)
  796. '
  797. '  SUBROUTINE PURPOSE -- Uncompress a 2 char date to get Y,M,D & display
  798. '
  799.       SUB UNCDATE (COMPRESSED.DATE$,YY,MM,DD,DISPLAY.DATE$) STATIC
  800.       CALL GETYMD (COMPRESSED.DATE$,1,YY)
  801.       CALL GETYMD (COMPRESSED.DATE$,2,MM)
  802.       CALL GETYMD (COMPRESSED.DATE$,3,DD)
  803.       DISPLAY.DATE$ = RIGHT$("00" + MID$(STR$(MM),2),2) + _
  804.                       "-" + _
  805.                       RIGHT$("00" + MID$(STR$(DD),2),2) + _
  806.                       "-" + _
  807.                       RIGHT$(STR$(YY),2)
  808.       END SUB
  809. ' $SUBTITLE: 'GETYMD -- subroutine to unpack a two-byte date'
  810. ' $PAGE
  811. '
  812. '  SUBROUTINE NAME    -- GETYMD
  813. '
  814. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  815. '                          TWOBYTE$    PACKED TWO-BYTE DATE FIELD
  816. '                            YMD       1 = YEAR
  817. '                                      2 = MONTH
  818. '                                      3 = DAY
  819. '                           RESULT     LOCATION TO PLACE THE RESULT
  820. '
  821. '  OUTPUT PARAMETERS  -- RESULT        FOUR DIGIT RESULT OF UNPAKING THE DATE
  822. '
  823. '  SUBROUTINE PURPOSE -- UNPACK A COMPRESSED TWO-BYTE DATE FIELD
  824. '
  825.       SUB GETYMD (TWOBYTE$,YMD,RESULT) STATIC
  826.       ON YMD GOTO 59205,59210,59215
  827.       EXIT SUB
  828. 59205 RESULT = (ASC(TWOBYTE$)AND NOT 1) / 2 + 1980
  829.       EXIT SUB
  830. 59210 RESULT = FIX((ASC(MID$(TWOBYTE$,2)) / 32)) OR ((ASC(TWOBYTE$) AND 1) * 8)
  831.       EXIT SUB
  832. 59215 RESULT = ASC(MID$(TWOBYTE$,2)) AND NOT 224
  833.       END SUB
  834. ' $SUBTITLE: 'PERSFILE - subroutine to process requests for personal files'
  835. ' $PAGE
  836. '
  837. '  SUBROUTINE NAME    -- PERSFILE
  838. '
  839. '  INPUT PARAMETERS   --     PARAMETER           MEANING
  840. '                            PERSONAL.CAT$     CATEGORY IN DIR FOR CALLER
  841. '                            PERSONAL.LEN      # CHARS IN PERSONAL CATEGORY
  842. '  OUTPUT PARAMETERS  -- NONE UP DOWNLOADS
  843. '
  844. '  SUBROUTINE PURPOSE -- SHOW CALLER WHAT PERSONAL FILES HAVE FOR
  845. '                        DOWNLOADING, VERIFY AND PROCESS REQUESTS FOR
  846. '                        DOWNLOADS
  847. '
  848. 59300 SUB PERSFILE (PERSONAL.CAT$,DOWNLOAD.FLAG) STATIC
  849.       CALL FINDIT (PERSONAL.DIR$)
  850. 59302 IF NOT OK THEN _
  851.          CALL QTPUT ("No personal files available",1) : _
  852.          Q = 0 : _
  853.          EXIT SUB
  854.       L = 36 + MAX.DESC.LEN + PERSONAL.LEN
  855.       IF LOF(2) < L THEN _
  856.         OK = FALSE : _
  857.         GOTO 59302
  858.       B$(0) = ""
  859.       CLOSE 2
  860.       IF SHARE.IT THEN _
  861.          OPEN PERSONAL.DIR$ FOR RANDOM SHARED AS #2 LEN=L _
  862.       ELSE OPEN "R",2,PERSONAL.DIR$,L
  863.       FIELD #2,33 + MAX.DESC.LEN AS PART.TO.PRINT$, _
  864.                PERSONAL.LEN    AS PRIVATE.CAT$, _
  865.                1               AS PERSONAL.STATUS$, _
  866.                2               AS FILLER$
  867.       MAX.PRINT = PAGE.LENGTH - 1
  868.       NON.STOP = NON.STOP OR (PAGE.LENGTH < 1)
  869.       LAST.REC = LOF(2) / L
  870.       IF DOWNLOADING THEN _
  871.          DOWNLOADING = FALSE : _
  872.          PERS.INDEX = DOWNLOAD.FLAG : _
  873.          DOWNLOAD.FLAG = 0 : _
  874.          GOTO 59306
  875.       IF Q > 1 THEN _
  876.          FOR I = 2 TO Q : _
  877.             B$(I - 1) = B$(I) : _
  878.          NEXT : _
  879.          Q = Q - 1 : _
  880.          GOTO 59304
  881. 59303 A$ = "Download what: L)ist, * = new, or file(s)" + _
  882.            PRESS.ENTER.EXPERT$
  883.       SUBROUTINE.PARAMETER = 1
  884.       CALL TGET
  885.       IF SUBROUTINE.PARAMETER = -1 OR Q = 0 THEN _
  886.          EXIT SUB
  887. 59304 SELECTED.PROTOCOL$ = ""
  888.       IF Q > 1 THEN _
  889.          IF LEN(B$(Q)) = 1 THEN _
  890.             SELECTED.PROTOCOL$ = B$(Q) : _
  891.             Q = Q - 1
  892.       IF LEN(B$(1)) > 2 THEN _
  893.          GOTO 59330
  894.       CALL ALLCAPS (B$(1))
  895.       ON INSTR("L*",B$(1)) GOTO 59305,59327
  896.       GOTO 59303
  897. 59305 PERS.INDEX = LAST.REC
  898.       L = FALSE
  899. 59306 IF PERS.INDEX < 1 THEN _
  900.          IF L THEN _
  901.             GOTO 59303 _
  902.          ELSE _
  903.             A$ = "No files for you" : _
  904.                  CALL QTPUT (A$,1) : _
  905.               GOTO 59303
  906.       GET #2,PERS.INDEX
  907.       PERS.INDEX = PERS.INDEX - 1
  908.       IF SYSOP THEN _
  909.          GOTO 59320
  910.       IF ASC(PRIVATE.CAT$) = 32 THEN _
  911.          IF USER.SECURITY.LEVEL < VAL(PRIVATE.CAT$) THEN _
  912.             GOTO 59306 _
  913.          ELSE GOTO 59308
  914.       IF PERSONAL.CAT$ <> PRIVATE.CAT$ THEN _
  915.          GOTO 59306
  916. 59308 L = TRUE
  917.       FILNAME$ = PERSONAL.DRVPATH$ + _
  918.                  LEFT$(PART.TO.PRINT$,12)
  919. 59320 IF PERSONAL.STATUS$ = "*" THEN _
  920.          A$ = "*" + PART.TO.PRINT$ _
  921.       ELSE A$ = " " + PART.TO.PRINT$
  922.       CALL COLORDIR (A$,"N")
  923.       IF LOCAL.USER THEN _
  924.          GOTO 59322
  925.       CALL EOFCOMM (CHAR%)
  926.       IF CHAR% <> -1 THEN _
  927.          GOTO 59323            ' comm port input
  928. 59322 KEYBOARD.STACK$ = INKEY$
  929.       IF KEYBOARD.STACK$ = "" THEN _  ' no keyboard input
  930.          CALL QTPUT (A$,1) : _
  931.          GOTO 59324
  932. 59323 SUBROUTINE.PARAMETER = 1
  933.       CALL TPUT
  934.       IF RET THEN _
  935.          GOTO 59303
  936.       IF SUBROUTINE.PARAMETER = -1 THEN _
  937.          GOTO 59335
  938. 59324 IF LINES.PRINTED <= MAX.PRINT THEN _
  939.          GOTO 59306
  940.       CALL TIMEREMAIN (TIME.REMAINING!)
  941.       IF TIME.REMAINING! < 0.1 THEN _
  942.          SUBROUTINE.PARAMETER = -1 : _
  943.          GOTO 59335
  944.       CALL CARRIER
  945.       IF SUBROUTINE.PARAMETER = -1 THEN _
  946.          GOTO 59335
  947.       IF NON.STOP THEN _
  948.          GOTO 59306
  949. 59325 IF PERS.INDEX > 0 THEN _
  950.          A$ = "MORE: [Y],N,C or download what (* = new)" _
  951.       ELSE GOTO 59303
  952.       SUBROUTINE.PARAMETER = 1
  953.       NO.ADVANCE = TRUE
  954.       CALL TGET
  955.       IF SUBROUTINE.PARAMETER = -1 THEN _
  956.          GOTO 59335
  957.       NON.STOP = (NON.STOP OR INSTR(" Cc",B$) > 1)
  958.       IF PERS.INDEX < 1 AND Q = 0 THEN _
  959.          GOTO 59335
  960.       CALL WIPELINE (78)
  961.       IF NO THEN _
  962.          GOTO 59303
  963.       IF LEN(B$(1)) > 2 THEN _
  964.          GOTO 59304
  965.       GOTO 59306
  966. 59327 PERS.INDEX = LAST.REC        ' handle new files
  967.       Q = 0
  968.       WHILE PERS.INDEX > 0 AND  Q < UBOUND(B$)
  969.          GET 2,PERS.INDEX
  970.          IF PERSONAL.CAT$ <> PRIVATE.CAT$ THEN _
  971.             GOTO 59329
  972.          IF PERSONAL.STATUS$ <> "*" THEN _
  973.             GOTO 59329
  974.          Q = Q + 1
  975.          I = Q
  976.          GOSUB 59336
  977.          IF OK THEN _
  978.             X$ = MID$(STR$(PERS.INDEX),2) : _
  979.             B$(0) = B$(0) + _
  980.                     X$ + _
  981.                     SPACE$(5 - LEN(X$)) _
  982.          ELSE Q = Q - 1
  983. 59329    PERS.INDEX = PERS.INDEX - 1
  984.       WEND
  985.       IF Q = 0 THEN _
  986.          A$ = "No new files for you" : _
  987.          CALL QTPUT (A$,1) : _
  988.          GOTO 59303
  989.       GOTO 59332
  990. 59330 I = 1              ' handle list of files
  991.       WHILE I <= Q
  992.          OK = FALSE
  993.          J = LAST.REC + 1
  994.          CALL ALLCAPS (B$(I))
  995.          WHILE J > 1 AND NOT OK
  996.             J = J - 1
  997.             GET #2,J
  998.             IF (PERSONAL.CAT$ = PRIVATE.CAT$ OR _
  999.                (ASC(PRIVATE.CAT$) = 32 AND _
  1000.                 USER.SECURITY.LEVEL => VAL(PRIVATE.CAT$))) THEN _
  1001.                    OK = (B$(I) = LEFT$(PART.TO.PRINT$,INSTR(PART.TO.PRINT$," ") - 1))
  1002.          WEND
  1003.          IF OK THEN _
  1004.             GOSUB 59336 : _
  1005.             IF OK THEN _
  1006.                X$ = MID$(STR$(J),2) : _
  1007.                B$(0) = B$(0) + _
  1008.                        X$ + _
  1009.                        SPACE$(5 - LEN(X$))
  1010.          IF NOT OK THEN _
  1011.             CALL QTPUT (B$(I) + " not found - omitted",1) : _
  1012.             FOR K = I + 1 TO Q : _
  1013.                B$(K - 1) = B$(K) : _
  1014.             NEXT : _
  1015.             Q = Q - 1 : _
  1016.             I = I - 1
  1017.          I = I + 1
  1018.       WEND
  1019.       IF Q = 0 THEN _
  1020.          GOTO 59303
  1021. 59332 DOWNLOAD.FLAG = PERS.INDEX          ' set protocol
  1022.       DOWNLOADING = TRUE
  1023.       B = 1
  1024.       IF SELECTED.PROTOCOL$ = "" THEN _
  1025.          IF PERSONAL.PROTOCOL$ <> " " THEN _
  1026.             SELECTED.PROTOCOL$ = PERSONAL.PROTOCOL$
  1027.       IF SELECTED.PROTOCOL$ <> "" THEN _
  1028.          Q = Q + 1 : _
  1029.          B$(Q) = SELECTED.PROTOCOL$
  1030.       EXIT SUB
  1031.  
  1032. 59335 CLOSE 2
  1033.       EXIT SUB
  1034. 59336 B$(I) = LEFT$(PART.TO.PRINT$,INSTR(PART.TO.PRINT$," ") - 1)
  1035.       CALL RBBSFIND (PERSONAL.DRVPATH$ + B$(I),Z,K,L,M)
  1036.       OK = (Z = 0)
  1037.       IF OK THEN _
  1038.          B$(I) = PERSONAL.DRVPATH$ + B$(I) _
  1039.       ELSE K = 0 : _
  1040.            WHILE K < SUBDIR.COUNT AND NOT OK : _
  1041.               K = K + 1 : _
  1042.               CALL RBBSFIND (SUBDIR$(K) + B$(I),Z,X,L,M) : _
  1043.               OK = (Z=0) : _
  1044.            WEND : _
  1045.            IF OK THEN _
  1046.               B$(I) = SUBDIR$(K) + B$(I)
  1047.       RETURN
  1048.       END SUB
  1049. ' $SUBTITLE: 'LOGDOWN -- subroutine to record private downloads'
  1050. ' $PAGE
  1051. '
  1052. '  SUBROUTINE NAME    -- LOGDOWN
  1053. '
  1054. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  1055. '
  1056. '  OUTPUT PARAMETERS  --
  1057. '
  1058. '  SUBROUTINE PURPOSE -- PUTS A "!" IN PLACE OF AN "*" IN PRIVATE
  1059. '                        DIRECTORY AFTER DOWNLOADED
  1060. '
  1061. 59400 SUB LOGDOWN (PRIVATE.DOWNLOAD,DWN.INDEX) STATIC
  1062.       IF NOT PRIVATE.DOWNLOAD THEN _
  1063.          EXIT SUB
  1064.       EN$ = PERSONAL.DIR$
  1065.       BX = &H4
  1066.       SUBROUTINE.PARAMETER = 9
  1067.       CALL FILELOCK
  1068.       L = 36 + MAX.DESC.LEN + PERSONAL.LEN
  1069.       CLOSE 2
  1070.       IF SHARE.IT THEN _
  1071.          OPEN EN$ FOR RANDOM SHARED AS #2 LEN=L _
  1072.       ELSE OPEN "R",2,PERSONAL.DIR$,L
  1073.       FIELD #2,L AS PERSONAL.REC$
  1074.       A = VAL(MID$(B$(0),5 * (DWN.INDEX - 1) + 1,5))
  1075.       GET #2,A
  1076.       MID$(PERSONAL.REC$,L-2,1) = "!"
  1077.       PUT #2,A
  1078.       BX = &H4
  1079.       SUBROUTINE.PARAMETER = 10
  1080.       CALL FILELOCK
  1081.       CLOSE 2
  1082.       END SUB
  1083. ' $SUBTITLE: 'USERFACE - subroutine to handle programmable user interface'
  1084. ' $PAGE
  1085. '
  1086. '  SUBROUTINE NAME    --  USERFACE
  1087. '
  1088. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  1089. '                         GDEFAULT$            GRAPHICS DEFAULT TO USE
  1090. '                         CURRENT.PUI$         PUI TO USE
  1091. '                         EXPERT.USER          WHETHER CALL IN EXPERT MODE
  1092. '
  1093. '  OUTPUT PARAMETERS  --  Q
  1094. '                         B$()
  1095. '                         Z$
  1096. '
  1097. '  SUBROUTINE PURPOSE --  WHEN SYSOP OVERRIDES RBBS-PC's DEFAULT USER
  1098. '                         INTERFACE (PROVIDES A MAIN.PUI), THIS ROUTINE
  1099. '                         READS IN THE TABLE OF SPECIFICATIONS, PRESENTS
  1100. '                         THE SYSOP MENU, PRESENTS THE PROMPT, VERIFIES
  1101. '                         THAT A VALID OPTION HAS BEEN PICKED, DETERMINES
  1102. '                         WHETHER THE OPTION IS ANOTHER PUI, AND PASSES
  1103. '                         BACK CHOICES TO BE PROCESSED.
  1104. '
  1105. 59450 SUB USERFACE (GDEFAULT$) STATIC
  1106. 59455 IF PREV.PUI$ = CURRENT.PUI$ THEN _
  1107.          GOTO 59458
  1108. 59456 FILE.NAME$ = CURRENT.PUI$
  1109.       CALL GRAPHIC (GDEFAULT$)
  1110.       IF NOT OK THEN _
  1111.          CALL UPDTCALR ("Missing menu " + CURRENT.PUI$,2) : _
  1112.          CURRENT.PUI$ = PREV.PUI$ : _
  1113.          GOTO 59456
  1114.       PREV.PUI$ = CURRENT.PUI$
  1115.       LINE INPUT #2,FILE.NAME$
  1116.       LINE INPUT #2,PRMPT$
  1117.       INPUT #2,VALID.CHOICE$,ACTUAL.COMMANDS$
  1118.       LINE INPUT #2,MENU.CHOICE$
  1119.       LINE INPUT #2,MENU.NAME$
  1120.       LINE INPUT #2,QUIT.COMMAND$
  1121.       LINE INPUT #2,QUIT.PROMPT$
  1122.       LINE INPUT #2,QUIT.SUBCOMMANDS$
  1123.       LINE INPUT #2,QUIT.MENUOPT$
  1124.       LINE INPUT #2,QUIT.MENUS$
  1125.       CALL GRAPHIC (GDEFAULT$)
  1126.       CALL BRKFNAME (FILE.NAME$,MENU.DRVPATH$,X$,Y$,TRUE)
  1127.       MENU.TO.DISPLAY$ = FILE.NAME$
  1128.       J = INSTR(ORIG.COMMANDS$,"?")
  1129.       IF J < 1 THEN _
  1130.          X$ = "" _
  1131.       ELSE X$ = MID$(ALL.OPTS$,J,1)
  1132. 59458 IF EXPERT.USER THEN _
  1133.          GOTO 59461
  1134. 59460 CALL BUFFILE (MENU.TO.DISPLAY$,X)
  1135. 59461 A$ = PRMPT$
  1136.       TURBO.KEY = -TURBO.KEY.USER
  1137.       SUBROUTINE.PARAMETER = 1
  1138.       CALL TGET
  1139.       IF SUBROUTINE.PARAMETER = -1 OR FUNCTION.KEY <> 0 THEN _
  1140.          EXIT SUB
  1141.       IF Q = 0 THEN _
  1142.          GOTO 59458
  1143. 59462 Z$ = B$(1)
  1144.       CALL ALLCAPS (Z$)
  1145.       IN.MACRO = FALSE
  1146.       J = INSTR(VALID.CHOICE$,Z$)
  1147.       IF J < 1 THEN _
  1148.          IF NOT IN.MACRO THEN _
  1149.             CALL CHKMACRO (Z$,IN.MACRO) : _
  1150.             IF IN.MACRO THEN _
  1151.                GOTO 59462 _
  1152.             ELSE GOTO 59492 _
  1153.          ELSE GOTO 59492
  1154.       Z$ = MID$(ACTUAL.COMMANDS$,J,1)
  1155.       B$(1) = Z$
  1156.       J = INSTR(MENU.CHOICE$,Z$)
  1157.       IF J > 0 THEN _
  1158.          CURRENT.PUI$ = MID$(MENU.NAME$,1 + (J - 1) * 7,7) : _
  1159.          GOTO 59490
  1160.       IF Z$ = X$ THEN _
  1161.          GOTO 59460
  1162.       IF Z$ <> QUIT.COMMAND$ THEN _
  1163.          EXIT SUB
  1164.       IF Q > 1 THEN _
  1165.          Y = 2 : _
  1166.          GOTO 59480
  1167. 59470 A$ = QUIT.PROMPT$
  1168.       TURBO.KEY = -TURBO.KEY.USER
  1169.       CALL TGET
  1170.       IF SUBROUTINE.PARAMETER = -1 OR FUNCTION.KEY <> 0 THEN _
  1171.          EXIT SUB
  1172.       IF Q = 0 THEN _
  1173.          GOTO 59458
  1174.       Y = 1
  1175. 59480 Z$ = B$(Y)
  1176.       CALL ALLCAPS (Z$)
  1177.       J = INSTR(QUIT.SUBCOMMANDS$,Z$)
  1178.       IF J < 1 THEN _
  1179.          GOTO 59470
  1180.       J = INSTR(QUIT.MENUOPT$,Z$)
  1181.       IF J > 0 THEN _ 'quit to submenu
  1182.          CURRENT.PUI$ = MID$(QUIT.MENUS$,1 + (J - 1) * 7,7) : _
  1183.          GOTO 59490
  1184.       IF Q = 1 THEN _  'valid but not menu - send to RBBS
  1185.          Q = 2 : _
  1186.          B$(2) = B$(1) : _
  1187.          B$(1) = QUIT.COMMAND$
  1188.       EXIT SUB
  1189. 59490 CALL REMOVE (CURRENT.PUI$," ")
  1190.       CURRENT.PUI$ = MENU.DRVPATH$ + _
  1191.                      CURRENT.PUI$ + _
  1192.                      ".PUI"
  1193.       GOTO 59455
  1194. 59492 CALL QTPUT (Z$ + " not valid choice",1)
  1195.       GOTO 59460
  1196.       END SUB
  1197. ' $SUBTITLE: 'SUBMENU -- subroutine to process menus'
  1198. ' $PAGE
  1199. '
  1200. '  SUBROUTINE NAME    -- SUBMENU
  1201. '
  1202. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  1203. '                        PASSED.PROMPT$  PROMPT TO DISPLAY
  1204. '                        CURRENT.MENU$   NOVICE MENU TO DISPLAY
  1205. '                        FRONT.OPT$      DRIVE/PATH/PREFIX OF FILE
  1206. '                                          NEEDED FOR TYPED OPTION
  1207. '                        BACK.OPT$       SUFFIX/EXTENSION OF FILE
  1208. '                                          NEEDED WITH TYPED OPTION
  1209. '                        RETURN.ON$      LETTERS CALLING PROGRAM WANTS
  1210. '                                          CONTROL ON
  1211. '                        GR.DEFAULT$     GRAPHICS DEFAULT TO USE
  1212. '                        VERIFY.IN.MENU  WHETHER VERIFY OPTION IS IN MENU
  1213. '                        ALL.MENU.OK     WHETHER CONTROL SHOULD RETURN
  1214. '                                          WHEN IN MENU
  1215. '                        ANS.INDEX       # OF COMMANDS IN TYPE AHEAD
  1216. '                        REQUIRE.IN.MENU WHETHER OPTION MUST BE IN MENU
  1217. '
  1218. '  OUTPUT PARAMETERS  -- Z$              OPTION PICKED
  1219. '                        FILE.NAME$      NAME OF FILE SUPPORTING OPTION
  1220. '
  1221. '
  1222. '  SUBROUTINE PURPOSE -- HANDLES MENUS - INCLUDING CONFERENCE, BULLETINS,
  1223. '                        DOORS, QUESTIONAIRES.  SUPPORTS SUB-MENUS (I.E.
  1224. '                        AN OPTION ON THE MENU THAT INVOKES ANOTHER MENU)
  1225. '
  1226. 59500 SUB SUBMENU (PASSED.PROMPT$,CURRENT.MENU$,FRONT.OPT$, _
  1227.                   BACK.OPT$,RETURN.ON$,GR.DEFAULT$,VERIFY.IN.MENU, _
  1228.                   ALL.MENU.OK,REQUIRE.IN.MENU,BACK.OPT2$) STATIC        'KG120501
  1229. 59510 FILE.NAME$ = CURRENT.MENU$
  1230.       CALL GRAPHIC (GR.DEFAULT$)
  1231.       CURRENT.MENU.VER$ = FILE.NAME$
  1232.       STOP.INTERRUPTS = FALSE
  1233.       IF ANS.INDEX > 1 THEN _
  1234.          Q = 1 : _
  1235.          GOTO 59530
  1236.       IF EXPERT.USER THEN _
  1237.          GOTO 59520
  1238. 59515 CALL BUFFILE (CURRENT.MENU.VER$,ANS.INDEX) 'show menu
  1239. 59520 A$ = PASSED.PROMPT$            'get response
  1240.       SUBROUTINE.PARAMETER = 1
  1241.       CALL TGET
  1242.       IF Q = 0 OR SUBROUTINE.PARAMETER = -1 THEN _
  1243.          EXIT SUB
  1244.       ANS.INDEX = 1
  1245.       LAST.INDEX = Q
  1246. 59530 Z$ = B$(ANS.INDEX)
  1247.       CALL ALLCAPS (Z$)
  1248.       IF INSTR(RETURN.ON$,Z$) THEN _  'check whether calling pgm wants
  1249.          EXIT SUB
  1250.       IF INSTR("LH?",Z$) THEN _       'check whether caller wants help
  1251.          GOTO 59515
  1252.       IF INSTR(Z$,".") > 0 THEN _
  1253.          GOTO 59545
  1254.       FILNAME$ = FRONT.OPT$ + _         'KG120501
  1255.                    Z$
  1256.       CALL BADFILE (FILNAME$,BF)                                     ' KG122801
  1257.       IF BF > 1 THEN _                                               ' KG122801
  1258.          OK = FALSE : _                                              ' KG122801
  1259.          GOTO 59547                                                  ' KG122801
  1260.       FILE.NAME$ = FILNAME$ + _                                      ' KG120501
  1261.                    BACK.OPT$
  1262.       CALL GRAPHIC (GR.DEFAULT$)
  1263.       IF NOT OK THEN _                                               ' KG120501
  1264.          IF BACK.OPT2$ <> "" THEN _                                  ' KG120501
  1265.             FILE.NAME$ = FILNAME$ + _                                ' KG120501
  1266.                          BACK.OPT2$ : _                              ' KG120501
  1267.             CALL GRAPHIC (GR.DEFAULT$)                               ' KG120501
  1268.       IF OK THEN _
  1269.          IF NOT REQUIRE.IN.MENU THEN _
  1270.             EXIT SUB _
  1271.          ELSE CALL WORDINFILE (CURRENT.MENU$,Z$,FOUND) : _
  1272.               IF FOUND THEN _
  1273.                  EXIT SUB _
  1274.               ELSE GOTO 59540
  1275.       IF NOT VERIFY.IN.MENU THEN _
  1276.          GOTO 59540
  1277.       CALL WORDINFILE (CURRENT.MENU$,Z$,FOUND)  'verify against menu itself
  1278.       IF FOUND THEN _
  1279.          IF ALL.MENU.OK THEN _
  1280.             EXIT SUB
  1281. 59540 X$ = FRONT.OPT$ + _
  1282.            Z$ + _
  1283.            ".MNU" 'check whether option is a menu
  1284.       FILE.NAME$ = X$
  1285.       CALL GRAPHIC (GR.DEFAULT$)
  1286.       IF OK THEN _
  1287.          CURRENT.MENU.VER$ = FILE.NAME$ : _
  1288.          CURRENT.MENU$ = X$ : _
  1289.          GOTO 59515
  1290.       IF VERIFY.IN.MENU AND FOUND AND NOT REQUIRE.IN.MENU THEN _
  1291.          CALL UPDTCALR("Option " + Z$ + " on menu " + _
  1292.                        CURRENT.MENU$ + " but not found",1)
  1293. 59545 IF INSTR(RETURN.ON$,LEFT$(Z$,1)) > 0 THEN _
  1294.          EXIT SUB
  1295. 59547 CALL QTPUT ("No such option " + Z$,1)
  1296.       GOTO 59515
  1297.       END SUB
  1298. ' $SUBTITLE: 'SETECHO -- subroutine to reset who echoes'
  1299. ' $PAGE
  1300. '
  1301. '  SUBROUTINE NAME    -- SETECHO
  1302. '
  1303. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  1304. '                          NEW.ECHO$   The new echo option
  1305. '                          LOCAL.USER
  1306. '
  1307. '  OUTPUT PARAMETERS  -- REMOTE.ECHO   Whether RBBS is to echo what a
  1308. '                                      remote caller types
  1309. '
  1310. '  SUBROUTINE PURPOSE -- Resets who echos.  "R" is for RBBS to echo.
  1311. '                        "I" is for intermediate host to echo.
  1312. '                        "C" is for caller's communication pgm to echo.
  1313. '
  1314. 59600 SUB SETECHO (NEW.ECHO$) STATIC
  1315.       IF NEW.ECHO$ = PREV.ECHO$ THEN _
  1316.          EXIT SUB
  1317.       IF NEW.ECHO$ = "R" THEN _
  1318.          REMOTE.ECHO = (NOT LOCAL.USER) _
  1319.       ELSE REMOTE.ECHO = FALSE
  1320.       IF LOCAL.USER THEN _
  1321.          GOTO 59602
  1322.       IF NEW.ECHO$ = "I" THEN _
  1323.           IF FOSSIL THEN _
  1324.              BYTES% = LEN(HOST.ECHO.ON$) : _
  1325.              CALL FOSWRITE(COMPORT%,BYTES%,HOST.ECHO.ON$) : _
  1326.              GOTO 59602 _
  1327.           ELSE PRINT #3,HOST.ECHO.ON$; : _
  1328.                GOTO 59602
  1329.       IF PREV.ECHO$ = "I" THEN _
  1330.           IF FOSSIL THEN _
  1331.              BYTES% = LEN(HOST.ECHO.OFF$) : _
  1332.              CALL FOSWRITE(COMPORT%,BYTES%,HOST.ECHO.OFF$) _
  1333.           ELSE PRINT #3,HOST.ECHO.OFF$;
  1334. 59602 PREV.ECHO$ = NEW.ECHO$
  1335.       END SUB
  1336. ' $SUBTITLE: 'MIMPORT -- subroutine to import a message'
  1337. ' $PAGE
  1338. '
  1339. '  SUBROUTINE NAME    -- MIMPORT
  1340. '
  1341. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  1342. '                          MAX.LINES     MAXIMUM # OF LINES
  1343. '                          MAX.LEN       MAXIMUM LENGTH OF A LINE
  1344. '                          NUM.LINES     NUMBER OF LINES ALREADY IN MESSAGE
  1345. '                          LINE.ARA$     ARRAY OF LINES IN MESSAGE
  1346. '
  1347. '  OUTPUT PARAMETERS       NUM.LINES
  1348. '                          LINE.ARA$
  1349. '
  1350. '  SUBROUTINE PURPOSE -- ALLOWS LOCAL USER TO APPEND A TEXT FILE TO
  1351. '                        A MESSAGE.   WILL WORD WRAP IF NECESSARY.
  1352. '
  1353.       SUB MIMPORT (MAX.LINES,MAX.LEN,NUM.LINES,LINE.ARA$(1)) STATIC
  1354.       IF NOT (LOCAL.USER OR SYSOP) THEN _
  1355.          CALL QTPUT ("Only for SYSOPS/local users",1) : _
  1356.          EXIT SUB
  1357. 59700 SUBROUTINE.PARAMETER = 1
  1358.       A$ = "Import what file" + PRESS.ENTER$
  1359.       CALL TGET
  1360.       IF SUBROUTINE.PARAMETER = -1 OR Q = 0 THEN _
  1361.          EXIT SUB
  1362.       CALL FINDIT (B$)
  1363.       IF NOT OK THEN _
  1364.          CALL QTPUT (B$ + " not found",1) : _
  1365.          GOTO 59700
  1366.       WHILE NOT EOF(2) AND NUM.LINES < MAX.LINES
  1367.          NUM.LINES = NUM.LINES + 1
  1368.          LINE INPUT #2,LINE.ARA$(NUM.LINES)
  1369.       WEND
  1370.       CLOSE 2
  1371.       CALL WORDWRAP (MAX.LEN,NUM.LINES,LINE.ARA$())
  1372.       END SUB
  1373. ' $SUBTITLE: 'WORDWRAP -- subroutine to wrap lines in a message'
  1374. ' $PAGE
  1375. '
  1376. '  SUBROUTINE NAME    -- WORDWRAP
  1377. '
  1378. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  1379. '                          MAX.LEN       MAXIMUM LENGTH OF A SINGLE LINE
  1380. '                          NUM.LINES     NUMBER OF LINES IN A MESSAGE
  1381. '                          LINE.ARA$     ALL THE LINES IN THE MESSAGE
  1382. '
  1383. '  OUTPUT PARAMETERS       NUM.LINES
  1384. '                          LINE.ARA$
  1385. '
  1386. '  SUBROUTINE PURPOSE -- BATCH ADJUSTS A MESSAGE, WRAPPING LINES IF
  1387. '                        NEEDED.  PRESERVES PARAGRAPH STRUCTURE.
  1388. '
  1389.       SUB WORDWRAP (MAX.LEN,NUM.LINES,LINE.ARA$(1)) STATIC
  1390.       J = 1
  1391.       WHILE J <= NUM.LINES
  1392.          CALL TRIMTRAIL (LINE.ARA$(J)," ")
  1393.          K = LEN(LINE.ARA$(J))
  1394.          IF K <= MAX.LEN THEN _
  1395.             GOTO 59705
  1396.          CALL FINDLAST (LINE.ARA$(J)," ",LAST.POS,HOW.MANY)
  1397.          IF LEFT$(LINE.ARA$(J + 1),2) = "  " THEN _
  1398.             FOR K = NUM.LINES TO J + 1 STEP -1 : _
  1399.                LINE.ARA$(K + 1) = LINE.ARA$(K) : _
  1400.             NEXT : _
  1401.             NUM.LINES = NUM.LINES + 1 : _
  1402.             LINE.ARA$(J + 1) = ""
  1403.          IF LAST.POS < 1 THEN _
  1404.             LINE.ARA$(J + 1) = MID$(LINE.ARA$(J),MAX.LEN) + LINE.ARA$(J + 1) : _
  1405.             LINE.ARA$(J) = LEFT$(LINE.ARA$(J),MAX.LEN - 1) + "-" _
  1406.          ELSE B$ = LEFT$(" ", - (LEN(LINE.ARA$(J + 1)) > 0)) : _
  1407.               LINE.ARA$(J + 1) = MID$(LINE.ARA$(J),LAST.POS + 1) + B$ + LINE.ARA$(J + 1) : _
  1408.               LINE.ARA$(J) = LEFT$(LINE.ARA$(J),LAST.POS - 1)
  1409. 59705    J = J + 1
  1410.       WEND
  1411.       NUM.LINES = NUM.LINES - (LEN(LINE.ARA$(NUM.LINES + 1)) > 0)
  1412.       END SUB
  1413. ' $SUBTITLE: 'SETABORT -- subroutine to set a time-limit'
  1414. ' $PAGE
  1415. '
  1416. '  SUBROUTINE NAME    -- SETABORT
  1417. '
  1418. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  1419. '                         SECONDS.TO.ADD # SECONDS AFTER CURRENT TIME
  1420. '                                        WHEN TIME LIMIT IS TO EXPIRE
  1421. '
  1422. '  OUTPUT PARAMETERS      ABORT.TIME!    THE TIME (IN SECONDS AFTER MIDNIGHT)
  1423. '                                           WHEN TIME LIMIT EXPIRES
  1424. '
  1425. '  SUBROUTINE PURPOSE -- SETS A TIME LIMIT IN UNITS OF SECONDS AFTER
  1426. '                        MIDNIGHT AFTER WHICH A TIME LIMIT WILL EXPIRE.
  1427. '                        CALLING PROGRAM PASSES NUMBER OF SECONDS THAT CAN
  1428. '                        ELASPE BEFORE TIME-LIMIT IS REACHED.
  1429. '
  1430. 59750 SUB SETABORT (ABORT.TIME!,SECONDS.TO.ADD) STATIC
  1431.       CALL FINDTIME (ABORT.TIME!)
  1432.       ABORT.TIME! = ABORT.TIME! + SECONDS.TO.ADD
  1433.       END SUB
  1434. ' $SUBTITLE: 'ANYBUT -- subroutine to find where a word begins'
  1435. ' $PAGE
  1436. '
  1437. '  SUBROUTINE NAME    -- ANYBUT
  1438. '
  1439. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  1440. '                          STRNG$        STRING TO SEARCH FOR WORDS
  1441. '                          BEG%          BYTE POSITION IN STRNG$ TO
  1442. '                                           BEGIN SEARCHING
  1443. '                          SKIP.CHARS$   CHARACTERS TO SKIP OVER WHEN
  1444. '                                           SEARCHING
  1445. '
  1446. '  OUTPUT PARAMETERS       WHEREIS%      BYTES POSITION IN STRNG$ WHERE
  1447. '                                           WORD BEGINS
  1448. '
  1449. '  SUBROUTINE PURPOSE -- PARSER.   FINDS WHERE A "WORD" BEGINS, WHERE
  1450. '                        ANY CHARACTER WILL BE ACCEPTED AS THE BEGINNING OF A
  1451. '                        WORD EXCEPT THOSE LISTED IN SKIP.CHAR$
  1452. '
  1453. 59760 SUB ANYBUT (STRNG$, BEG%, SKIP.CHARS$, WHEREIS%) STATIC
  1454.       X$ = STRNG$ + _
  1455.            CHR$(0)
  1456.       WHEREIS% = BEG%
  1457.       IF WHEREIS% < 1 THEN _
  1458.          WHEREIS% = 1
  1459.       WHILE INSTR(SKIP.CHARS$, MID$(X$, WHEREIS%, 1)) > 0
  1460.          WHEREIS% = WHEREIS% + 1
  1461.       WEND
  1462.       IF WHEREIS% > LEN(STRNG$) THEN _
  1463.          WHEREIS% = 0
  1464.       END SUB
  1465. ' $SUBTITLE: 'FINDEND -- subroutine to find where a word ends'
  1466. ' $PAGE
  1467. '
  1468. '  SUBROUTINE NAME    -- FINDEND
  1469. '
  1470. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  1471. '                          STRNG$        STRING TO SEARCH FOR WORDS
  1472. '                          BEG%          POSITION IN STRNG$ TO BEGIN SEARCH
  1473. '                          STOP.WITH$    CHARACTERS THAT TERMINATE A WORD
  1474. '
  1475. '  OUTPUT PARAMETERS       WHEREIS%      POSITION IN STRNG$ WHERE WORD ENDS
  1476. '                                        (I.E. THE LAST CHARACTER OF THE WORD)
  1477. '
  1478. '  SUBROUTINE PURPOSE -- PARSER.   FINDS WHERE A "WORD" ENDS, WHERE
  1479. '                        ANY CHARACTER WILL BE COUNTED AS IN A WORD
  1480. '                        EXCEPT FOR THOSE IN STOP.WITH$ OR WHEN THE END OF
  1481. '                        THE STRING IS FOUND.
  1482. '
  1483. 59770 SUB FINDEND (STRNG$, BEG%, STOP.WITH$, WHEREIS%) STATIC
  1484.       B = BEG%
  1485.       IF B < 1 THEN _
  1486.          B = 1
  1487.       IF B > LEN(STRNG$) THEN _
  1488.          X$ = STOP.WITH$ _
  1489.       ELSE X$ = MID$(STRNG$, B) + _
  1490.                 STOP.WITH$
  1491.       I = 1
  1492.       X = INSTR(STOP.WITH$, MID$(X$, I, 1))
  1493.       WHILE X = 0
  1494.          I = I + 1
  1495.          X = INSTR(STOP.WITH$, MID$(X$, I, 1))
  1496.       WEND
  1497.       WHEREIS% = I - 1 + B - 1
  1498.       END SUB
  1499. ' $SUBTITLE: 'GETALL -- subroutine to create directory list'
  1500. ' $PAGE
  1501. '
  1502. '  SUBROUTINE NAME    -- GETALL
  1503. '
  1504. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  1505. '                          LOOK.IN$      NAME OF FILE TO SEARCH
  1506. '                          DIR.EXT$      MAIN DIRECTORY EXTENSION TO USE
  1507. '                          START.POS     LAST POSITION USED IN ARRAY
  1508. '
  1509. '  OUTPUT PARAMETERS       START.POS     LAST ELEMENT USED IN ARRAY
  1510. '                          LOAD.INTO$    ARRAY TO LOAD ELEMENTS FOUND
  1511. '
  1512. '  SUBROUTINE PURPOSE -- CREATES A LIST (LOAD.INTO$) OF ALL DIRECTORIES
  1513. '                        FOUND IN DIRECTORY OF DIRECTORIES (LOOK.IN$).
  1514. '                        USED FOR DETERMING WHAT GETS LISTED WHEN DOING
  1515. '                        AN "ALL" TO DETERMINATE WHAT SEPERATE DIRECTORIES
  1516. '                        TO DISPLAY.  DIRECTORY NAME MUST BE ALL CAPS
  1517. '                        AND FOLLOWED BY A SPACE OR DASH.
  1518. '
  1519. 59780 SUB GETALL (LOOK.IN$, LOAD.INTO$(1), DIR.EXT$, START.POS) STATIC
  1520.       IF MASTER.DIRECTORY.NAME$ <> "" THEN _
  1521.          START.POS = START.POS + 1 : _
  1522.          LOAD.INTO$(START.POS) = MASTER.DIRECTORY.NAME$ : _
  1523.          EXIT SUB
  1524.       CALL FINDIT(LOOK.IN$)
  1525.       IF NOT OK THEN _
  1526.          EXIT SUB
  1527.       MAX.LOAD = UBOUND(LOAD.INTO$, 1)
  1528.       START.SORT = START.POS + 1
  1529.       WHILE NOT EOF(2) AND START.POS < MAX.LOAD
  1530.          LINE INPUT #2, A$
  1531.          LAST.POS = LEN(A$)
  1532.          CALL ANYBUT(A$, 1, " ", X)
  1533.          WHILE X > 0 AND X < LAST.POS AND START.POS < MAX.LOAD
  1534.             CALL FINDEND(A$, X + 1, " -.", Y)
  1535.             L = Y - X + 1
  1536.             IF L > 8 THEN _
  1537.                GOTO 59782
  1538.             B$ = MID$(A$, X, L)
  1539.             IF B$ = "ALL" THEN _
  1540.                GOTO 59782
  1541.             CALL BADFILECHAR (B$,I)
  1542.             IF NOT I THEN _
  1543.                GOTO 59782
  1544.             Z$ = LEFT$(B$,1)
  1545.             IF (Z$ >= "0" AND Z$ <= "9") OR _
  1546.                (Z$ >= "A" AND Z$ <= "Z") THEN _
  1547.                   Z$ = B$ : _
  1548.                   CALL ALLCAPS (Z$) : _
  1549.                   IF Z$ = B$ THEN _
  1550.                      LOAD.INTO$(START.POS + 1) = Z$ : _
  1551.                      IF USE.DIR.ORDER THEN _
  1552.                         I = START.SORT : _
  1553.                         WHILE LOAD.INTO$(I) <> Z$ : _
  1554.                            I = I + 1 : _
  1555.                         WEND : _
  1556.                         START.POS = START.POS - (I > START.POS) _
  1557.                      ELSE _
  1558.                         I = START.SORT : _
  1559.                         Z = VAL(Z$) : _
  1560.                         WHILE VAL(LOAD.INTO$(I)) < Z : _
  1561.                            I = I + 1 : _
  1562.                         WEND : _
  1563.                         WHILE VAL(LOAD.INTO$(I)) = Z AND LOAD.INTO$(I) < Z$ AND I <= START.POS : _
  1564.                            I = I + 1 : _
  1565.                         WEND : _
  1566.                         IF I > START.POS THEN _
  1567.                            START.POS = I _
  1568.                         ELSE IF Z$ <> LOAD.INTO$(I) THEN _
  1569.                                 FOR J = START.POS TO I STEP -1 : _
  1570.                                    LOAD.INTO$(J + 1) = LOAD.INTO$(J) : _
  1571.                                 NEXT : _
  1572.                                 LOAD.INTO$(I) = Z$ : _
  1573.                                 START.POS = START.POS + 1
  1574. 59782       CALL ANYBUT(A$, Y + 1, " ", X)
  1575.          WEND
  1576.       WEND
  1577.       CLOSE 2
  1578.       END SUB
  1579. ' $SUBTITLE: 'FINDFILE -- subroutine to find a file'
  1580. ' $PAGE
  1581. '
  1582. '  SUBROUTINE NAME    --  FINDFILE
  1583. '
  1584. '  INPUT PARAMETERS   --  PARAMETER         MENANING
  1585. '                         FILNAME$         NAME OF FILE TO LOOK FOR
  1586. '                         FEXISTS          WHETHER FILE EXISTS
  1587. '
  1588. '  OUTPUT PARAMETERS  --  RETURNED.VALUE   VALUE RETURNED
  1589. '                                          TRUE  = FILE EXISTS
  1590. '                                          FALSE = FILE DOES NOT EXIST
  1591. '
  1592. '  SUBROUTINE PURPOSE --  DETERMINE WHETHER PASSED FILE FILNAME$ EXISTS
  1593. '                         UNLIKE, FINDIT, THIS ROUTINE DOES NOT OPEN ANY
  1594. '                         FILE AND, HENCE, DOES NOT CREATE ONE IN DETERMINIG
  1595. '                         IF A FILE EXISTS.
  1596. '
  1597. 59790 SUB FINDFILE (FILNAME$,FEXISTS) STATIC
  1598.       CALL BADFILECHAR (FILNAME$,FEXISTS)
  1599.       IF FEXISTS THEN _
  1600.          CALL RBBSFIND (FILNAME$,Z,Y,M,D) : _
  1601.          FEXISTS = (Z = 0)
  1602.       END SUB
  1603. ' $SUBTITLE: 'BADFILECHAR -- subroutine to check file for illegal char'
  1604. ' $PAGE
  1605. '
  1606. '  SUBROUTINE NAME    --  BADFILECHAR
  1607. '
  1608. '  INPUT PARAMETERS   --  PARAMETER         MEANING
  1609. '                         FILNAME$         NAME OF FILE TO CHECK
  1610. '
  1611. '  OUTPUT PARAMETERS  --  IS.OK            WHETHER NAME OK
  1612. '
  1613. '  SUBROUTINE PURPOSE --  Part of test for file's existence.  If bad
  1614. '                         character in name, can't exist.
  1615. '
  1616. 59800 SUB BADFILECHAR (FILNAME$,IS.OK) STATIC
  1617.      L = LEN(FILNAME$)
  1618.       X$ = FILNAME$ + "="
  1619.       I = 1
  1620.       WHILE INSTR("/[]|<>+=;,",MID$(X$,I,1)) = 0 AND ASC(MID$(X$,I)) < 128
  1621.          I = I + 1
  1622.       WEND
  1623.       IS.OK = I > L
  1624.       END SUB
  1625. '
  1626. ' $SUBTITLE: 'CONFMAIL -- subroutine to quickly check mail waiting'
  1627. ' $PAGE
  1628. '
  1629. '  SUBROUTINE NAME    -- CONFMAIL
  1630. '
  1631. '  INPUT PARAMETERS   -- PARAMETER        MEANING
  1632. '                    CONFMAIL.LIST$       File of user/message pairs to check
  1633. '                    ACTIVE.USER.FILE$    Active user file (restored on exit)
  1634. '                    ACTIVE.MESSAGE.FILE$ Active msg file (restored)
  1635. '  OUTPUT PARAMETERS  -- None
  1636. '
  1637. '  SUBROUTINE PURPOSE -- Quicking scans message header record to get
  1638. '                        last msg # and user record to get whether any
  1639. '                        new mail and last msg read, reports both, using
  1640. '                        highlighting if new mail to caller.
  1641. '
  1642. 59850 SUB CONFMAIL STATIC
  1643.       IF START.HASH = 1 AND USER.FILE.INDEX > 0 THEN _   'KG102101
  1644.          CALL FINDIT (CONFMAIL.LIST$) _
  1645.       ELSE OK = FALSE
  1646.       IF NOT OK THEN _
  1647.          EXIT SUB
  1648.       CALL SKIPLINE (1)
  1649.       CALL QTPUT (CX$(5)+"Checking  "+CX$(6)+ "Message Bases since last on..."+CX$(3),1)
  1650.       ANY.MAIL = FALSE
  1651.       STOP.INTERRUPTS = FALSE
  1652.       A1$ = ACTIVE.USER.FILE$
  1653.       M$ = ACTIVE.MESSAGE.FILE$
  1654.       TEMP.INDIV.VALUE$ = ""
  1655.       SUIX = USER.FILE.INDEX
  1656.       USER.RECORD.HOLD$ = USER.RECORD$
  1657.       OK = TRUE
  1658. 59852 IF EOF(2) OR NOT OK THEN _
  1659.          GOTO 59854
  1660.          CALL READANY
  1661.          ACTIVE.USER.FILE$ = A$
  1662.          CALL READANY
  1663.          IF EC > 0 THEN _
  1664.             GOTO 59854
  1665.          ACTIVE.MESSAGE.FILE$ = A$
  1666.          CALL FINDFILE (ACTIVE.USER.FILE$,OK)
  1667.          IF NOT OK THEN _
  1668.             GOTO 59854
  1669.          CALL OPENUSER (HIGHEST.USER.RECORD)
  1670.          FIELD 5, 128 AS USER.RECORD$
  1671.          CALL FINDFILE (ACTIVE.MESSAGE.FILE$,OK)
  1672.          IF NOT OK THEN _
  1673.             GOTO 59854
  1674.          CALL FINDUSER (ORIG.USER.NAME$,"",START.HASH,LEN.HASH,_     ' KG102702
  1675.                         0,0,HIGHEST.USER.RECORD,_                    ' KG102702
  1676.                         FOUND,UFI,SL)
  1677.          IF NOT FOUND THEN _
  1678.             GOTO 59852
  1679.          CALL OPENMSG
  1680.          FIELD 1, 128 AS MESSAGE.RECORD$
  1681.          GET 1,1
  1682.          ANY.MAIL = TRUE
  1683.          X = CVI(MID$(USER.RECORD$,57,2))
  1684.          X = (X AND 512) > 0
  1685.          CALL BRKFNAME (ACTIVE.USER.FILE$,X$,Y$,Z$,FALSE)
  1686.          A = CVI(MID$(USER.RECORD$,51,2))
  1687.          B = VAL(LEFT$(MESSAGE.RECORD$,8))
  1688.          Z = (B - A)
  1689.          IF Z < 1 THEN _
  1690.             X = FALSE
  1691.          A$ = MID$(STR$((B>A)*Z),2)
  1692.          SL = LEN(A$)
  1693.          A$ = SPACE$(-(SL<3) * (3-SL)) + A$
  1694.          SL = LEN(Y$)
  1695.          Y$ = LEFT$(Y$,SL-1) + SPACE$(-(SL<8) * (8-SL))
  1696.          IF X THEN _
  1697.             X$ = EMPHASIZE.ON$ : _
  1698.             Z$ = EMPHASIZE.OFF$ _
  1699.          ELSE X$ = "" : _
  1700.               Z$ = ""
  1701.          A$ = Y$ + ": " + A$ + " new message(s) - " + _
  1702.               X$ + MID$("NoneSome",-4*X+1,4) + " to you" + Z$
  1703.          SUBROUTINE.PARAMETER = 5
  1704.          CALL TPUT
  1705.          CALL ASKMORE ("",TRUE,TRUE,X,TRUE)
  1706.       IF NOT RET THEN _
  1707.          GOTO 59852
  1708. 59854 ACTIVE.USER.FILE$ = A1$
  1709.       CALL OPENUSER (HIGHEST.USER.RECORD)
  1710.       FIELD 5, 128 AS USER.RECORD$
  1711.       IF (NOT RET) AND NOT ANY.MAIL THEN _
  1712.          CALL QTPUT ("No new personal mail",1)
  1713.       USER.FILE.INDEX = SUIX
  1714.       LSET USER.RECORD$ = USER.RECORD.HOLD$
  1715.       ACTIVE.MESSAGE.FILE$ = M$
  1716.       CALL OPENMSG
  1717.       FIELD 1, 128 AS MESSAGE.RECORD$
  1718.       GET 1,1
  1719.       END SUB
  1720. ' $SUBTITLE: 'ASKMORE -- subroutine to pause when possible screen full'
  1721. ' $PAGE
  1722. '
  1723. '  SUBROUTINE NAME    -- ASKMORE
  1724. '
  1725. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  1726. '                          EXTRA.PRMPT$  STRING TO ADD TO MORE PROMPT AT END
  1727. '                          OVERWRITE     WHETHER TO WIPE AWAY PROMPT
  1728. '
  1729. '  OUTPUT PARAMETERS  --   B$()
  1730. '                          NO
  1731. '
  1732. '  SUBROUTINE PURPOSE -- DETERMINES WHETHER NEED TO PAUSE IF SCREEN FULL.
  1733. '                        AND, IF SO, ASKS THE APPROPRIATE QUESTION.  IF NON-
  1734. '                        STOP, AT LEAST CHECK FOR CARRIER PRESENT.
  1735. '
  1736.       SUB ASKMORE (EXTRA.PRMPT$, OVERWRITE, CHECK.LINES,ABORT.INDEX,CANT.INTERRUPT) STATIC
  1737.       NO = FALSE
  1738.       IF CHECK.LINES THEN _
  1739.          X = -DISPLAY.AS.UNIT*UNIT.COUNT -(NOT DISPLAY.AS.UNIT)*LINES.PRINTED : _
  1740.          IF X < PAGE.LENGTH THEN _
  1741.             Q = 0 : _
  1742.             EXIT SUB
  1743.       IF ONE.STOP THEN _
  1744.          ONE.STOP = FALSE : _
  1745.          NON.STOP = TRUE : _
  1746.          GOTO 59860
  1747.       IF NON.STOP THEN _
  1748.          LINES.PRINTED = 0 : _
  1749.          CALL CARRIER : _
  1750.          IF KEYBOARD.STACK$ = "" AND COMMPORT.STACK$ = "" THEN _
  1751.             EXIT SUB _
  1752.          ELSE NON.STOP = FALSE
  1753. 59860 CALL QTPUT (EMPHASIZE.OFF$,0)
  1754.       IF CANT.INTERRUPT THEN _
  1755.          TURBO.KEY = 2 : _
  1756.          A$ = "Press Any Key to continue" _
  1757.       ELSE A$ = MORE.PROMPT$ + EXTRA.PRMPT$ + LEFT$(">",-EXPERT.USER)
  1758.       X = LEN(A$) + 2
  1759.       NO.ADVANCE = OVERWRITE
  1760.       SUBROUTINE.PARAMETER = 1
  1761.       IF EXTRA.PRMPT$ = "" AND TURBO.KEY = 0 THEN _
  1762.          TURBO.KEY = -TURBO.KEY.USER
  1763.       CALL TGET
  1764.       IF SUBROUTINE.PARAMETER = -1 THEN _                            ' JM120601
  1765.         EXIT SUB                                                     ' JM120601
  1766.       TURBO.KEY = FALSE
  1767.       NON.STOP = NON.STOP OR (INSTR(" Cc",B$) > 1)
  1768.       CALL WIPELINE (X + LEN(B$))
  1769.       IF CANT.INTERRUPT THEN _
  1770.          NO = FALSE : _
  1771.          EXIT SUB
  1772.       IF INSTR(" Aa",B$) > 1 THEN _
  1773.          ABORT.INDEX = 32000
  1774.       IF NO THEN _
  1775.          KEYBOARD.STACK$ = "" : _
  1776.          COMMPORT.STACK$ = ""
  1777.       END SUB
  1778. ' $SUBTITLE: 'COMPDATE -- subroutine to compute elased days'
  1779. ' $PAGE
  1780. '
  1781. '  SUBROUTINE NAME    -- COMPDATE
  1782. '
  1783. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  1784. '                            YY        YEAR
  1785. '                            MM        MONTH
  1786. '                            DD        DAY
  1787. '                           RESULT!    LOCATION TO PLACE THE RESULT
  1788. '
  1789. '  OUTPUT PARAMETERS  -- RESULT!       COMPUTE COMPUTATIONAL DATE
  1790. '
  1791. '  SUBROUTINE PURPOSE -- COMPUTES A COMPUTATIONAL DATE FROM YEAR, MONTH, DAY.
  1792. '                        RESULTS MAY BE USED TO COMPUTE THE NUMBER OF ELASPED
  1793. '                        DAYS BETWEEN TWO DATES.  YOU MAY PASS A 2 OR 4 DIGIT
  1794. '                        YEAR, BUT FOR MEANINGFUL RESULTS, BE CONSISTENT
  1795. '
  1796.       SUB COMPDATE (YY,MM,DD,RESULT!) STATIC
  1797.       IF MM < 1 OR MM > 12 THEN _
  1798.          MM = 1
  1799.       RESULT! = YY * 365.0 + _
  1800.                 INT((YY - 1) / 4) + _
  1801.                 (MM - 1) * 28 + _
  1802.                 VAL(MID$("000303060811131619212426",(MM - 1) * 2 + 1,2)) - _
  1803.                 ((MM > 2) AND ((YY MOD 4) = 0)) + _
  1804.                 DD
  1805.       END SUB
  1806. ' $SUBTITLE: 'EXPDATE -- subroutine to display expiration date'
  1807. ' $PAGE
  1808. '
  1809. '  SUBROUTINE NAME    -- EXPDATE
  1810. '
  1811. '  INPUT PARAMETERS   --   PARAMETER           MEANING
  1812. '                        REGISTRATION.DATE!    COMPUTATIONAL REGISTRATION DATE
  1813. '                        REGISTRATION.PERIOD   DAYS IN REGISTRATION PERIOD
  1814. '
  1815. '  OUTPUT PARAMETERS  -- EXP.DATE$             DISPLAYABLE EXPIRATION DATE
  1816. '
  1817. '  SUBROUTINE PURPOSE -- COMPUTES/CREATES A DISPALYABLE REGISTRATION
  1818. '                        EXPIRATION DATE USING REGISTRATION DATE AND DAYS IN
  1819. '                        REGISTRATION PERIOD.
  1820. '
  1821.       SUB EXPDATE (REGISTRATION.DATE!,REGISTRATION.PERIOD,EXP.DATE$) STATIC
  1822.       EXPIRE.DATE! = REGISTRATION.DATE! + REGISTRATION.PERIOD
  1823.       EXPIRE.YEAR! = INT((EXPIRE.DATE! - EXPIRE.DATE! / 1461) / 365)
  1824.       EXPIRE.DAY% = EXPIRE.DATE! - (EXPIRE.YEAR! * 365 + INT((EXPIRE.YEAR! -1)/4))
  1825.       EXPIRE.MONTH% = -((EXPIRE.YEAR! MOD 4)<>0) * _
  1826.                       (1 - (EXPIRE.DAY% > 31) - (EXPIRE.DAY% > 59) - _
  1827.                       (EXPIRE.DAY% > 90) - (EXPIRE.DAY% >120) - _
  1828.                       (EXPIRE.DAY% > 151) - (EXPIRE.DAY% > 181) - _
  1829.                       (EXPIRE.DAY% > 212) - (EXPIRE.DAY% > 243) - _
  1830.                       (EXPIRE.DAY% > 273) - (EXPIRE.DAY% > 304) - _
  1831.                       (EXPIRE.DAY% > 334)) - ((EXPIRE.YEAR! MOD 4) = 0) * _
  1832.                       (1 - (EXPIRE.DAY% > 31) - (EXPIRE.DAY% > 60) - _
  1833.                       (EXPIRE.DAY% > 91) - (EXPIRE.DAY% >121) - _
  1834.                       (EXPIRE.DAY% > 152) - (EXPIRE.DAY% > 182) - _
  1835.                       (EXPIRE.DAY% > 213) - (EXPIRE.DAY% > 243) - _
  1836.                       (EXPIRE.DAY% > 274) - (EXPIRE.DAY% > 305) - _
  1837.                       (EXPIRE.DAY% > 335))
  1838.       EXPIRE.DAY% = (EXPIRE.DAY% - ((EXPIRE.MONTH% - 1) * 28 + _
  1839.          VAL(MID$("000303060811131619212426",(EXPIRE.MONTH% -1) * 2 + 1,2)))) + _
  1840.          ((EXPIRE.MONTH% > 2) AND ((EXPIRE.YEAR! MOD 4) = 0))
  1841.       EXP.DATE$ = RIGHT$("0" + MID$(STR$(EXPIRE.MONTH%),2),2) + _
  1842.                   "/" + _
  1843.                   RIGHT$("0" + MID$(STR$(EXPIRE.DAY%),2),2) + _
  1844.                   "/" + _
  1845.                   RIGHT$(STR$(EXPIRE.YEAR!),2)
  1846.       END SUB
  1847. ' $SUBTITLE: 'COLORDIR - subroutine to build a color FMS directory string'        'RW060701
  1848. ' $PAGE                                                                           'RW060701
  1849. '                                                                                 'RW060701
  1850. '  SUBROUTINE NAME    --  COLORDIR                                                'RW060701
  1851. '                                                                                 'RW060701
  1852. '  INPUT PARAMETERS   --  PARAMETER                   MEANING                     'RW060701
  1853. '                         STRNG$              String to alter                     'RW060701
  1854. '                         FMS.DIR$            "Y" FOR FMS DIR                     'RW060701
  1855. '                                             "N" FOR PERSONAL DOWNLOADS          'RW060701
  1856. '                                                                                 'RW060701
  1857. 59920 SUB COLORDIR (STRNG$,FMS.DIR$) STATIC                                       'RW060701
  1858.       IF GR < 2 THEN _
  1859.          EXIT SUB
  1860.       IF FMS.DIR$ = "N" THEN _
  1861.          GOTO 59921
  1862. '
  1863. ' INSERT COLOR FOR FILENAME 
  1864. '
  1865.       ON INSTR("\ *",LEFT$(STRNG$,1)) GOTO 59924,59922,59923
  1866. 59921 STRNG$ = DR.1$ + LEFT$(STRNG$,13) + DR.2$ + MID$(STRNG$,14,10) + _
  1867.                DR.3$ + MID$(STRNG$,24,10) + DR.4$ + MID$(STRNG$,34,MAX.DESC.LEN)
  1868.       EXIT SUB
  1869. 59922 STRNG$ = DR.4$ + STRNG$
  1870.       EXIT SUB
  1871. 59923 STRNG$ = EMPHASIZE.OFF$ + STRNG$
  1872. 59924 END SUB
  1873. ' $SUBTITLE: 'CHKCOLOR - subroutine to highlight based on search string'
  1874. ' $PAGE
  1875. '
  1876. '  SUBROUTINE NAME    --  CHKCOLOR
  1877. '
  1878. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  1879. '                         LOOK.FOR$           String that triggers highlight
  1880. '                         LOOK.IN$            String being searched
  1881. '                         END.COLOR$          Terminating color
  1882. '
  1883. '  OUTPUT PARAMETERS  --  STRNG$              Revised string
  1884. '
  1885. '  SUBROUTINE PURPOSE --  Adds highlighting to a string within a string.
  1886. '                         Respects previous colorization.
  1887.       SUB CHKCOLOR (LOOK.IN$,LOOK.FOR$,PASSED.END.COLOR$) STATIC
  1888.       IF LOOK.FOR$ = "" THEN _
  1889.          EXIT SUB
  1890.       X$ = LOOK.IN$
  1891.       CALL ALLCAPS (X$)
  1892.       START.COLOR = INSTR(X$,LOOK.FOR$)
  1893.       IF START.COLOR < 1 THEN _
  1894.          EXIT SUB
  1895.       END.COLOR$ = PASSED.END.COLOR$
  1896.       IF END.COLOR$ = "" THEN _
  1897.          END.COLOR$ = EMPHASIZE.OFF$ : _
  1898.          CALL FINDLAST (LEFT$(LOOK.IN$,START.COLOR-1),ESCAPE$,WHERE.FOUND,J) : _
  1899.          IF WHERE.FOUND > 0 THEN _
  1900.             J = INSTR(WHERE.FOUND,LOOK.IN$,"m") : _
  1901.             IF J > 0 THEN _
  1902.                END.COLOR$ = MID$(LOOK.IN$,WHERE.FOUND,J-WHERE.FOUND+1)
  1903.       CALL BRACKET (LOOK.IN$,START.COLOR,START.COLOR + LEN(LOOK.FOR$)-1,EMPHASIZE.ON$,END.COLOR$)
  1904. '     CALL COLORIZE (LOOK.IN$,START.COLOR + LEN(LOOK.FOR$) - 1,START.COLOR,EMPHASIZE.ON$,END.COLOR$)
  1905.       END SUB
  1906. ' $SUBTITLE: 'SETHILITE - subroutine to reset highlight preference'
  1907. ' $PAGE
  1908. '
  1909. '  SUBROUTINE NAME    --  SETHILITE
  1910. '
  1911. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  1912. '                         SET.TO              New value (True or False)
  1913. '                         EMPHASIZE.ON.DEF$   String turns emphasize on
  1914. '                         EMPHASIZE.OFF.DEF$  String turns emphasize off
  1915. '
  1916. '  OUTPUT PARAMETERS  --  HIGHLIGHT.OFF       Callers preference on Hilite
  1917. '                         EMPHASIZE.ON$       String to use for emphasis
  1918. '                         EMPHASIZE.OFF$      String to use after emphasis
  1919. '
  1920.       SUB SETHILITE (SET.TO) STATIC
  1921.       HIGHLIGHT.OFF = (EMPHASIZE.ON.DEF$ <> "" AND SET.TO)
  1922.       IF HIGHLIGHT.OFF THEN _
  1923.          EMPHASIZE.ON$ = "" : _
  1924.          EMPHASIZE.OFF$ = "" : _
  1925.          FG.1$ = "" : _
  1926.          FG.2$ = "" : _
  1927.          FG.3$ = "" : _
  1928.          FG.4$ = "" _
  1929.       ELSE EMPHASIZE.ON$ = EMPHASIZE.ON.DEF$ : _
  1930.            FG.1$ = FG.1.DEF$ : _
  1931.            FG.2$ = FG.2.DEF$ : _
  1932.            FG.3$ = FG.3.DEF$ : _
  1933.            FG.4$ = FG.4.DEF$
  1934.       END SUB
  1935. ' $SUBTITLE: 'COLORPMT - subroutine to colorize prompts'
  1936. ' $PAGE
  1937. '
  1938. '  SUBROUTINE NAME    --  COLORPMT
  1939. '
  1940. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  1941. '                         STRNG$              String to colorize
  1942. '                         HIGHLIGHT.OFF       Whether highlighting is off
  1943. '                         EMPHASIZE.ON$       String to use for emphasis
  1944. '                         EMPHASIZE.OFF$      String to use after emphasis
  1945. '
  1946. '  OUTPUT PARAMETERS  --  STRNG$              Colorized string
  1947. '
  1948. '  SUBROUTINE PURPOSE -- colorizes a string based on sysop settings
  1949. '                        and the string.
  1950. '                        [...] is the default - put in emphasis
  1951. '                        <...> options to type - put in FG.4$
  1952. '                           and first two precedign words use FG.1$ and FG.2$
  1953. '                        options identified on right by ) and on
  1954. '                           left by space or comma - put in FG.4$
  1955. '
  1956.       SUB COLORPMT (STRNG$) STATIC
  1957.       IF HIGHLIGHT.OFF THEN _
  1958.          EXIT SUB
  1959.       ALREADY.COLORIZED = (INSTR(STRNG$,ESCAPE$) > 0)
  1960.       X = INSTR(STRNG$,"<")
  1961.       IF X > 0 THEN _
  1962.          GOTO 59943
  1963.       X = INSTR(STRNG$,"[")   ' highlight default
  1964.       IF X > 0 THEN _
  1965.          Y = INSTR(X,STRNG$,"]") : _
  1966.          IF Y > 0 THEN _
  1967.             CALL BRACKET (STRNG$,X,Y,EMPHASIZE.ON$,EMPHASIZE.OFF$)
  1968.       IF ALREADY.COLORIZED THEN _
  1969.          EXIT SUB
  1970.       X = INSTR(STRNG$,"<")
  1971.       IF X < 1 THEN _
  1972.          GOTO 59945
  1973. 59943 Y = INSTR(X,STRNG$,">")
  1974.       IF Y < 1 THEN _
  1975.          GOTO 59945
  1976.       CALL BRACKET (STRNG$,X,Y,FG.4$,EMPHASIZE.OFF$)
  1977.       Y = INSTR(STRNG$," ")
  1978.       IF Y > 1 AND Y < X THEN _
  1979.          STRNG$ = FG.1$ + STRNG$ : _
  1980.          Z = INSTR(Y+1,STRNG$," ") : _
  1981.          IF Z > 1 AND Z < X+LEN(FG.1$) THEN _
  1982.             STRNG$ = LEFT$(STRNG$,Z) + FG.2.DEF$ + MID$(STRNG$,Z+1)
  1983.       EXIT SUB
  1984. 59945 X = 1
  1985.       DID.INSERT = FALSE
  1986.       L = LEN(FG.4$)
  1987. 59950 Y = INSTR (X,STRNG$,")")  ' x: where command begins, y: terminating pos
  1988.       Z = INSTR (X,STRNG$,",")
  1989.       IF Y = 0 OR (Z > 0 AND Z < Y) THEN _
  1990.          Y = Z
  1991.       K = LEN(STRNG$)
  1992.       IF X > K THEN _
  1993.          EXIT SUB
  1994.       IF Y < 1 THEN _
  1995.          IF NOT DID.INSERT THEN _
  1996.             EXIT SUB _
  1997.          ELSE Y = K+1
  1998.       Z = Y - 1
  1999.       WHILE Z > 0    ' got terminating pos: find beginning
  2000.          IF INSTR(OPTION.END$,MID$(STRNG$,Z,1)) > 0 THEN _
  2001.             X = Z + 1 : _
  2002.             Z = 0
  2003.          Z = Z - 1
  2004.       WEND
  2005.       IF Y-X < 3 THEN _     ' exclude commands too long
  2006.          CMND.STRNG$ = MID$(STRNG$,X,Y-X) : _
  2007.          X$ = CMND.STRNG$ : _
  2008.          CALL ALLCAPS (CMND.STRNG$) : _
  2009.          IF X$ = CMND.STRNG$ THEN _  ' exclude lower case
  2010.             DID.INSERT = TRUE : _
  2011.             CALL BRACKET (STRNG$,X,Y-1,FG.4$,EMPHASIZE.OFF$) : _  ' colorize
  2012.             Y = Y + L
  2013.       X = Y + 1
  2014.       GOTO 59950
  2015.       END SUB
  2016. ' $SUBTITLE: 'BRACKET - Inserts strings around a string'
  2017. ' $PAGE
  2018. '
  2019. '  SUBROUTINE NAME    --  BRACKET
  2020. '
  2021. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2022. '                         STRNG$              Insert in this string
  2023. '                         B4.HERE             Insert 1st before this pos
  2024. '                         AFTER.HERE          Insert 2nd after this pos
  2025. '                         B4.STRNG$           String to insert before
  2026. '                         AFTER.STRNG$        String to insert after
  2027. '
  2028. '  OUTPUT PARAMETERS  --  STRNG$
  2029. '
  2030. '  SUBROUTINE PURPOSE -- Primarily for colorization
  2031. '
  2032.       SUB BRACKET (STRNG$,B4.HERE,AFTER.HERE,B4.STRNG$,AFTER.STRNG$) STATIC
  2033.       STRNG$ = LEFT$(STRNG$,B4.HERE-1) + _
  2034.                B4.STRNG$ + _
  2035.                MID$(STRNG$,B4.HERE,AFTER.HERE-B4.HERE+1) + _
  2036.                AFTER.STRNG$ + _
  2037.                RIGHT$(STRNG$,LEN(STRNG$) - AFTER.HERE)
  2038.       END SUB
  2039. ' $SUBTITLE: 'USERCOLOR - lets user set color for normal text'
  2040. ' $PAGE
  2041. '
  2042. '  SUBROUTINE NAME    --  USERCOLOR
  2043. '
  2044. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2045. '                         EMPHASIZE.OFF$      Normal text color
  2046. '
  2047. '  OUTPUT PARAMETERS  --  EMPHASIZE.OFF$      New text color
  2048. '                         BOLD.TEXT$          Whether bold (0 not, 1 bold)
  2049. '                         USER.TEXT.COLOR     ANSI Color selected
  2050. '
  2051. '  SUBROUTINE PURPOSE -- Lets caller select desired color and whether
  2052. '                        bold.
  2053.       SUB USERCOLOR STATIC
  2054.       IF HIGHLIGHT.OFF THEN _
  2055.          EXIT SUB
  2056. 59970 CALL QTPUT (EMPHASIZE.OFF$,0)
  2057.       A$ = "Make text R)ed,G)reen,Y)ellow,B)lue,P)urple,C)yan,W)hite" + PRESS.ENTER.EXPERT$
  2058.       GOSUB 59973
  2059.       IF Q = 0 THEN _
  2060.          EMPHASIZE.OFF$ = ESCAPE$ + "[" + BOLD.TEXT$ + _
  2061.              ";40;" + MID$(STR$(USER.TEXT.COLOR),2) + "m" : _
  2062.          EXIT SUB
  2063.       CALL ALLCAPS (B$)
  2064.       X = INSTR("RGYBPCW",B$)
  2065.       IF X = 0 THEN _
  2066.          GOTO 59970
  2067.       USER.TEXT.COLOR = 30 + X
  2068.       A$ = "Make text BOLD (Y,[N])"
  2069.       GOSUB 59973
  2070.       BOLD.TEXT$ = CHR$(48 - YES)
  2071.       EMPHASIZE.OFF$ = ESCAPE$ + "[" + BOLD.TEXT$ + ";40;" + MID$(STR$(USER.TEXT.COLOR),2) + "m"
  2072.       GOTO 59970
  2073. 59973 SUBROUTINE.PARAMETER = 1
  2074.       TURBO.KEY = -TURBO.KEY.USER
  2075.       CALL TGET
  2076.       IF SUBROUTINE.PARAMETER = -1 THEN _
  2077.          EXIT SUB
  2078.       RETURN
  2079.       END SUB
  2080. ' $SUBTITLE: 'SETUGD - Sets user graphic preference'
  2081. ' $PAGE
  2082. '
  2083. '  SUBROUTINE NAME    --  SETUGD
  2084. '
  2085. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2086. '                        GRAPHICS.NUMBER   0=None, 1=Ascii, 2=color
  2087. '
  2088. '  OUTPUT PARAMETERS  -- GR                Shared var - set to
  2089. '                                            graphics.number
  2090. '                        GRAPHICS.LETTER$  What add to file name to
  2091. '                                            see if got graphics file ver
  2092. '
  2093. '  SUBROUTINE PURPOSE -- Sets file graphics preference
  2094. '
  2095.       SUB SETUGD (GRAPHICS.NUMBER,GRAPHICS.LETTER$) STATIC
  2096.       GR = GRAPHICS.NUMBER
  2097.       IF GR = 2 THEN _
  2098.          DR.1$ = FG.1.DEF$ : _
  2099.          DR.2$ = FG.2.DEF$ : _
  2100.          DR.3$ = FG.3.DEF$ : _
  2101.          DR.4$ = FG.4.DEF$ _
  2102.       ELSE DR.1$ = "" : _
  2103.            DR.2$ = "" : _
  2104.            DR.3$ = "" : _
  2105.            DR.4$ = "" 
  2106.       GRAPHICS.LETTER$ = MID$(" GC",GR+1, - (GR > 0))
  2107.       END SUB
  2108. ' $SUBTITLE: 'EOFCOMM - Determines whether input in comm port buffer'
  2109. ' $PAGE
  2110. '
  2111. '  SUBROUTINE NAME    --  EOFCOMM
  2112. '
  2113. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2114. '                         FOSSIL              Whether fossil driver used
  2115. '                         COMPORT%            Comm port # in use
  2116. '
  2117. '  OUTPUT PARAMETERS  --  NOCHARS%           -1 (TRUE) if no chars in buffer.
  2118. '                                             Anything else means has char.
  2119. '
  2120. '  SUBROUTINE PURPOSE -- Query comm port to see if input waiting
  2121. '
  2122. 60000 SUB EOFCOMM (NOCHARS%) STATIC
  2123.       IF FOSSIL THEN _
  2124.          CALL FOSREADAHEAD(COMPORT%,NOCHARS%) _
  2125.       ELSE NOCHARS% = EOF(3)
  2126.       END SUB
  2127. ' $SUBTITLE: 'GSANDR - Global search and replace'
  2128. ' $PAGE
  2129. '
  2130. '  SUBROUTINE NAME    --  GSANDR
  2131. '
  2132. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2133. '                         STRNG$              String to edit
  2134. '                         LOOK.FOR$           String to look for
  2135. '                         REPLACE.BY$         String to replace by
  2136. '
  2137. '  OUTPUT PARAMETERS  --  STRNG$              Edited string
  2138. '
  2139. '  SUBROUTINE PURPOSE --  Replaces every occurence of LOOK.FOR$ that
  2140. '                         is in STRNG$ by REPLACE.BY$
  2141. '
  2142. 60100 SUB GSANDR (STRNG$,LOOK.FOR$,REPLACE.BY$) STATIC
  2143.       IF LOOK.FOR$ = "" THEN _
  2144.          EXIT SUB
  2145.       X = 1
  2146.       L = LEN(REPLACE.BY$)
  2147.       M = LEN(LOOK.FOR$)
  2148. 60102 Y = INSTR(X,STRNG$,LOOK.FOR$)
  2149.       IF Y < 1 THEN _
  2150.          EXIT SUB
  2151.       STRNG$ = LEFT$(STRNG$,Y-1) + _
  2152.                REPLACE.BY$ + _
  2153.                RIGHT$(STRNG$,LEN(STRNG$)-Y+1-M)
  2154.       X = Y + L
  2155.       IF X > LEN(STRNG$) THEN _
  2156.          EXIT SUB
  2157.       GOTO 60102
  2158.       END SUB
  2159. ' $SUBTITLE: 'METAGSR -- Meta Global search and replace'
  2160. ' $PAGE
  2161. '
  2162. '  SUBROUTINE NAME    --  METAGSR
  2163. '
  2164. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2165. '                         STRNG$              String to edit
  2166. '
  2167. '  OUTPUT PARAMETERS  --  STRNG$              Edited string
  2168. '
  2169. '  SUBROUTINE PURPOSE --  Sets up the file transfer META statements
  2170. '
  2171.       SUB METAGSR (STRNG$) STATIC
  2172.       IF BATCH.TRANSFER THEN _
  2173.          CALL GSANDR (STRNG$,"[FILE]","@"+NODE.WORK.FILE$) _
  2174.       ELSE CALL GSANDR (STRNG$,"[FILE]",FILE.NAME$)
  2175.       CALL GSANDR (STRNG$,"[BAUD]",TALK.TO.MODEM.AT$)
  2176.       CALL GSANDR (STRNG$,"[PORT]",COM.PORT$)
  2177.       CALL GSANDR (STRNG$,"[PORT#]",MID$(COM.PORT$,4))
  2178.       CALL GSANDR (STRNG$,"[PARITY]",MID$(BAUD.PARITY$,INSTR(BAUD.PARITY$,",")+1,1))
  2179.       CALL GSANDR (STRNG$,"[PROTO]",FT$)
  2180.       CALL GSANDR (STRNG$,"[NODE]",NODE.ID$)
  2181.       I = 1
  2182.       X$ = "[1]"
  2183.       WHILE INSTR(STRNG$,X$) > 0
  2184.          CALL GSANDR (STRNG$,X$,A$(I))
  2185.          I = I + 1
  2186.          X$ = "["+MID$(STR$(I),2)+"]"
  2187.       WEND
  2188.       END SUB
  2189. ' $SUBTITLE: 'TIMELOCK - Test TIME LOCK for premium features'
  2190. ' $PAGE
  2191. '
  2192. '  SUBROUTINE NAME    --  TIMELOCK  (written by Doug Azzarito)
  2193. '
  2194. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2195. '                         TIME.LOCK.SET               SECONDS/SESSION TO LOCK
  2196. '
  2197. '  OUTPUT PARAMETERS  --  SUBROUTINE.PARAMETER     -1 if feature is LOCKED
  2198. '
  2199. '  SUBROUTINE PURPOSE -- Check elapsed time for lock duration
  2200. '
  2201. 60150 SUB TIMELOCK STATIC
  2202.       CALL TIMEREMAIN(TIME.REMAINING!)
  2203.       IF TCA! > TIME.LOCK.SET THEN _
  2204.          OK = TRUE : _
  2205.          EXIT SUB
  2206.       CALL BUFFILE(HELP.PATH$+"TIMELOCK"+HELP.EXTENSION$,X)
  2207.       IF NOT OK THEN _
  2208.          CALL QTPUT("Sorry, " + FIRST.NAME$ + _
  2209.                     ", function unavailable for first" + _
  2210.                     STR$(TIME.LOCK.SET) + "seconds",1)
  2211.       OK = FALSE
  2212.       END SUB
  2213. ' $PAGE
  2214. '
  2215. '  SUBROUTINE NAME    --  MARKTIME
  2216. '
  2217. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2218. '                         DOT.NUMBER          How many dots printed
  2219. '
  2220. '  OUTPUT PARAMETERS  --  DOT.NUMBER
  2221. '
  2222. '  SUBROUTINE PURPOSE --  Marks time by putting colorized dots out
  2223. '                         to 4, then erasing
  2224. '
  2225. 60200 SUB MARKTIME (DOT.NUMBER) STATIC
  2226.       CALL FINDTIME (TI!)
  2227.       IF TI! - PREV.TI! < 1.0 THEN _
  2228.          EXIT SUB
  2229.       PREV.TI! = TI!
  2230.       IF REMOVE.DOT AND DOT.NUMBER > 0 THEN _
  2231.          CALL QTPUT (BACKSPACE$,0) : _
  2232.          DOT.NUMBER = DOT.NUMBER - 1 : _
  2233.          EXIT SUB
  2234.       DOT.NUMBER = DOT.NUMBER + 1
  2235.       ON DOT.NUMBER GOTO 60201,60202,60203,60204
  2236. 60201 X$ = FG.1$
  2237.       REMOVE.DOT = FALSE
  2238.       GOTO 60205
  2239. 60202 X$ = FG.2$
  2240.       GOTO 60205
  2241. 60203 X$ = FG.3$
  2242.       GOTO 60205
  2243. 60204 X$ = FG.4$
  2244.       REMOVE.DOT = TRUE
  2245. 60205 CALL QTPUT (X$ + "." + EMPHASIZE.OFF$,0)
  2246.       END SUB
  2247. ' $SUBTITLE: 'AUTOPAGE - NOTIFIES SYSOP WHEN SPECIFIC USER CALLS'
  2248. ' $PAGE
  2249. '
  2250. '  SUBROUTINE NAME   --  AUTOPAGE   'Contributed  by Gregg and Bob Snyder
  2251. '                                   'and RoseMarie Siddiqui
  2252. '
  2253. '  INPUT PARAMETERS  --  AUTOPAGE.DEF$  List of conditions that trigger
  2254. '                                       notification and how
  2255. '
  2256. '  OUTPUT PARAMETERS  -- NONE
  2257. '
  2258. '  SUBROUTINE PURPOSE -- Search AUTOPAGE.DEF$ for match on whether
  2259. '                        on name, security level, whether new user.
  2260. '                        Also controls whether caller notified and
  2261. '                        number of times sysop has bell rung.
  2262. '                        And what tune to play (if any).
  2263. '
  2264. 60300 SUB AUTOPAGE STATIC
  2265.       CALL FINDIT (AUTOPAGE.DEF$)
  2266.       IF NOT OK THEN _
  2267.          EXIT SUB
  2268.       EC = 0
  2269.       OK = FALSE
  2270.       WHILE NOT EOF(2) AND OK = FALSE AND EC = 0
  2271.          CALL READPARMS (WORK.ARA$(),4,1)
  2272.          IF EC = 0 THEN _
  2273.             OK = (WORK.ARA$(1) = ACTIVE.USER.NAME$) : _
  2274.             IF NOT OK THEN _
  2275.                IF NEW.USER AND WORK.ARA$(1) = "NEWUSER" THEN _
  2276.                   OK = TRUE _
  2277.                ELSE IF LEFT$(WORK.ARA$(1),1) = "/" AND LEN(WORK.ARA$(1)) > 2 THEN _
  2278.                        B = INSTR (2,WORK.ARA$(1),"/") : _
  2279.                        IF B > 0 AND LEN(WORK.ARA$(1)) > B THEN _
  2280.                           IF USER.SECURITY.LEVEL <= VAL(MID$(WORK.ARA$(1),B+1)) AND _
  2281.                              USER.SECURITY.LEVEL >= VAL(MID$(WORK.ARA$(1),2)) THEN _
  2282.                                 OK = TRUE
  2283.       WEND
  2284.       CLOSE 2
  2285.       IF EC > 0 OR NOT OK THEN _                                     ' KG122702
  2286.          EC = 0 : _                                                  ' KG122702
  2287.          EXIT SUB
  2288.       PAGE.STATUS$ = "AutoPaged!"
  2289.       IF LEFT$(WORK.ARA$(2),1) = "N" THEN _
  2290.          A$ = "Notifying Sysop of your presence" : _            'KG122702
  2291.          CALL RINGCALLER
  2292.       B = (WORK.ARA$(4) = "")
  2293.       WORK.ARA$(5) = ""
  2294.       FOR I = 1 TO VAL(WORK.ARA$(3))
  2295.          IF B THEN _
  2296.             CALL LPRNT (BELL.RINGER$,0) : _                          ' KG120905
  2297.          ELSE WORK.ARA$(5) = WORK.ARA$(5) + "O4 X" + VARPTR$(WORK.ARA$(4))
  2298.       NEXT
  2299.       IF NOT B THEN _
  2300.          CALL RBBSPLAY (WORK.ARA$(5))           'KG122702
  2301.       END SUB
  2302. ' $SUBTITLE: 'PUTMATTR - subroutine to save msg. attributes'
  2303. ' $PAGE
  2304. '
  2305. '  SUBROUTINE NAME    --  PUTMATTR
  2306. '
  2307. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2308. '                         Q
  2309. '                         B$
  2310. '                         LINES.IN.MESSAGE
  2311. '                         S
  2312. '                         NON.STOP
  2313. '                         MESSAGE.DIM.INDEX
  2314. '
  2315. '  OUTPUT PARAMETERS  --  SQ
  2316. '                         LG$(10)
  2317. '                         LINES.IN.MESSAGE.SAVE
  2318. '                         SL
  2319. '                         NON.STOP.SAVE
  2320. '                         MESSAGE.DIM.INDEX.SAVE
  2321. '
  2322. '  SUBROUTINE PURPOSE --  WHEN REPLYING TO A MESSAGE THIS ROUTINE SAVES
  2323. '                         THE ATTRIBUTES OF THE ORGINAL MESSAGE
  2324. '
  2325. 62520 SUB PUTMATTR STATIC
  2326.       SQ = Q
  2327.       LG$(10) = B$
  2328.       LINES.IN.MESSAGE.SAVE = LINES.IN.MESSAGE
  2329.       SL = S
  2330.       NON.STOP.SAVE = NON.STOP
  2331.       MESSAGE.DIM.INDEX.SAVE = MESSAGE.DIM.INDEX
  2332.       END SUB
  2333. ' $SUBTITLE: 'GETMATTR - subroutine to get msg. attributes'
  2334. ' $PAGE
  2335. '
  2336. '  SUBROUTINE NAME    --  GETMATTR
  2337. '
  2338. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2339. '                         SQ
  2340. '                         LG$(10)
  2341. '                         LINES.IN.MESSAGE.SAVE
  2342. '                         SL
  2343. '                         NON.STOP.SAVE
  2344. '                         MESSAGE.DIM.INDEX.SAVE
  2345. '
  2346. '  OUTPUT PARAMETERS  --  Q
  2347. '                         B$
  2348. '                         LINES.IN.MESSAGESAVE
  2349. '                         S
  2350. '                         NON.STOP
  2351. '                         MESSAGE.DIM.INDEX
  2352. '                         KILL.MESSAGE
  2353. '
  2354. '  SUBROUTINE PURPOSE --  AFTER REPLYING TO A MESSAGE THIS ROUTINE RESTORES
  2355. '                         THE ATTRIBUTES OF THE ORGINAL MESSAGE
  2356. '
  2357. 62530 SUB GETMATTR STATIC
  2358.       Q = SQ
  2359.       B$ = LG$(10)
  2360.       LINES.IN.MESSAGE = LINES.IN.MESSAGE.SAVE
  2361.       S = SL
  2362.       NON.STOP = NON.STOP.SAVE
  2363.       MESSAGE.DIM.INDEX = MESSAGE.DIM.INDEX.SAVE
  2364.       KILL.MESSAGE = FALSE
  2365.       END SUB
  2366. ' $SUBTITLE: 'RPTTIME -- Reports time on system'
  2367. ' $PAGE
  2368. '
  2369. '  SUBROUTINE NAME    --  RPTTIME
  2370. '
  2371. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2372. '
  2373. '  OUTPUT PARAMETERS  --
  2374. '
  2375. '  SUBROUTINE PURPOSE --  Tells user time used on system
  2376. '
  2377.       SUB RPTTIME STATIC
  2378.       CALL SKIPLINE (1)
  2379.       CALL GETIME
  2380.       SUBROUTINE.PARAMETER = 2
  2381.       CALL AMORPM
  2382.       QX = ((HHH * 60) + MMM + (SSS / 60.0)) * 10.0
  2383.       Q! = QX / 10.0
  2384.       MINS = (HHH * 60) + MMM
  2385.       CALL CARRIER
  2386.       IF SUBROUTINE.PARAMETER = -1 THEN _
  2387.          EXIT SUB
  2388.       CALL QTPUT(FG.1$+"Now: " +FG.2$+ DATE$ +FG.3$+ " at "+FG.4$ + TIME$,1)
  2389.       CALL QTPUT(FG.4$+"On for"+FG.3$ + STR$(MINS)+FG.2$ + " mins,"+FG.1$ + STR$(SSS) + " secs"+EMPHASIZE.OFF$,1)
  2390.       END SUB
  2391. ' $SUBTITLE: 'PROTOCOL - Determine protocols available'
  2392. ' $PAGE
  2393. '
  2394. '  SUBROUTINE NAME    -- PROTOCOL
  2395. '
  2396. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  2397. '                        PROTO.DEF$                File of installed protocols
  2398. '
  2399. '   OUTPUT PARAMETERS -- TRANSFER.OPTIONS$         Prompt for protocol choice
  2400. '                        DFLTXFER$                 Letters of protocols
  2401. '                        INTERNAL.EQUIV$           Internal protocol to use
  2402. '
  2403. '  SUBROUTINE PURPOSE -- TO determine what protocols are available to user
  2404. '
  2405.       SUB PROTOCOL STATIC
  2406. 62600 CALL FINDIT (PROTO.DEF$)
  2407.       IF NOT OK THEN _
  2408.          TRANSFER.OPTIONS$ = "A)scii,X)modem,C)rcXmodem,Y)modem" : _
  2409.          INTERNAL.EQUIV$ = "AXCY" : _
  2410.          DFLTXFER$ = "AXCY" : _
  2411.          GOTO 62604
  2412.       DFLTXFER$ = ""
  2413.       INTERNAL.EQUIV$ = ""
  2414.       TRANSFER.OPTIONS$ = ""
  2415.       L = 0
  2416. 62602 IF EOF(2) THEN _
  2417.          GOTO 62604
  2418.       CALL READPARMS (WORK.ARA$(),13,1)
  2419.       IF EC > 0 THEN _
  2420.          EXIT SUB
  2421.       DFLTXFER$ = DFLTXFER$ + " "
  2422.       INTERNAL.EQUIV$ = INTERNAL.EQUIV$ + " "
  2423.       IF USER.SECURITY.LEVEL < VAL(WORK.ARA$(2)) THEN _
  2424.          GOTO 62602
  2425.       IF LEFT$(WORK.ARA$(5),1) = "R" THEN _
  2426.          IF NOT RELIABLE.MODE THEN _
  2427.             GOTO 62602
  2428.       IF LEFT$(WORK.ARA$(3),1) = "I" THEN _
  2429.          GOTO 62603
  2430.       X = INSTR(WORK.ARA$(12)+" "," ")
  2431.       X$ = LEFT$(WORK.ARA$(12),X-1)
  2432.       CALL FINDFILE (X$,FOUND)
  2433.       IF FOUND THEN _
  2434.          X = INSTR(WORK.ARA$(13)+" "," ") : _
  2435.          X$ = LEFT$(WORK.ARA$(13),X-1) : _
  2436.          CALL FINDFILE (X$,FOUND)
  2437.       IF NOT FOUND THEN _
  2438.          GOTO 62602
  2439. 62603 MID$(DFLTXFER$,LEN(DFLTXFER$),1) = LEFT$(WORK.ARA$(1),1)
  2440.       CALL FINDLAST (WORK.ARA$(1),CRLF$,X,I)
  2441.       IF X > 0 AND X >= LEN(WORK.ARA$(1)) - 2 THEN _
  2442.          WORK.ARA$(1) = LEFT$(WORK.ARA$(1),X-1)
  2443.       IF (L + LEN(WORK.ARA$(1)) < 62) AND X = 0 THEN _
  2444.          TRANSFER.OPTIONS$ = TRANSFER.OPTIONS$ + "," + WORK.ARA$(1) : _
  2445.          L = L + LEN(WORK.ARA$(1)) + 1 _
  2446.       ELSE L = LEN(WORK.ARA$(1)) : _
  2447.            TRANSFER.OPTIONS$ = TRANSFER.OPTIONS$ + _
  2448.                               CRLF$ + _
  2449.                               WORK.ARA$(1)
  2450.       IF LEFT$(WORK.ARA$(3),1) = "I" AND RIGHT$(WORK.ARA$(3),1) <> "I" THEN _
  2451.          MID$(INTERNAL.EQUIV$,LEN(INTERNAL.EQUIV$),1) = RIGHT$(WORK.ARA$(3),1)
  2452.       GOTO 62602
  2453. 62604 IF INSTR(INTERNAL.EQUIV$,"N") > 0 THEN _
  2454.          GOTO 62605
  2455.       IF X = 0 THEN _
  2456.          TRANSFER.OPTIONS$ = TRANSFER.OPTIONS$ + ",N)one" _
  2457.       ELSE TRANSFER.OPTIONS$ = TRANSFER.OPTIONS$ + CRLF$ + "N)one"
  2458.       DFLTXFER$ = DFLTXFER$ + "N"
  2459.       INTERNAL.EQUIV$ = INTERNAL.EQUIV$ + "N"
  2460. 62605 IF LEFT$(TRANSFER.OPTIONS$,1) = "," THEN _
  2461.          TRANSFER.OPTIONS$ = MID$(TRANSFER.OPTIONS$,2)
  2462.       IF INSTR(DFLTXFER$,USER.TRANSFER.DEFAULT$) = 0 THEN _
  2463.          CALL QTPUT ("Protocol "+USER.TRANSFER.DEFAULT$+" unavailable.  Default reset to None",1) : _
  2464.          USER.TRANSFER.DEFAULT$ = MID$(DFLTXFER$,INSTR(INTERNAL.EQUIV$,"N"),1)
  2465.            END SUB
  2466. ' $SUBTITLE: 'TRANSFER - subroutine for KERMIT, YMODEM, IMODEM & YMODEM'
  2467. ' $PAGE
  2468. '
  2469. '  SUBROUTINE NAME    -- TRANSFER
  2470. '
  2471. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  2472. '                        TRANSFER.FUNCTION         = 1 DOWNLOAD FILE TO USER
  2473. '                                                  = 2 UPLOAD FILE TO RBBS-PC
  2474. '                        FILE.NAME$                NAME OF FILE FOR TRANSFER
  2475. '                        COM.PORT$                 NAME OF COMMUNICATIONS PORT
  2476. '                                                  TO BE USED BY KERMIT (COM1
  2477. '                                                  OR COM2)
  2478. '                        BPS                       = -1 FOR   300 BAUD
  2479. '                                                  = -2 FOR   450 BAUD
  2480. '                                                  = -3 FOR  1200 BAUD
  2481. '                                                  = -4 FOR  2400 BAUD
  2482. '                                                  = -5 FOR  4800 BAUD
  2483. '                                                  = -6 FOR  9600 BAUD
  2484. '                                                  = -7 FOR 19200 BAUD
  2485. '                        PCKERMIT.EXE.FILE$        FILE TO TRANSFER CONTROL TO
  2486. '                                                  FOR KERMIT PROTOCOL ON
  2487. '                                                  PROTOCOL.PATH$.
  2488. '                        QMXFER.COM.FILE$          FILE TO TRANSFER CONTROL TO
  2489. '                                                  FOR YMODEM, IMODEM OR
  2490. '                                                  YMODEMG PROTOCOLS.
  2491. '                        WXMODEM.COM.FILE$         FILE TO TRANSFER CONTROL TO
  2492. '                                                  FOR WXMODEM PROTOCOL ON
  2493. '                                                  PROTOCOL.PATH$
  2494. '
  2495. '  OUTPUT PARAMETERS  -- NONE
  2496. '
  2497. '  SUBROUTINE PURPOSE -- TO TRANSFER FILES USING KERMIT, YMODEM, IMODEM,
  2498. '                        YMODEMG OR WXMODEM PROTOCOL'S
  2499. '
  2500. 62620 SUB TRANSFER STATIC
  2501.       IF PRIVATE.DOOR THEN _
  2502.          CALL XFRETURN : _
  2503.          EXIT SUB
  2504.       IF TRANSFER.FUNCTION = 1 THEN _
  2505.          B$ = DOWN.TEMPLATE$ : _
  2506.          Z$ = "send " _
  2507.       ELSE IF TRANSFER.FUNCTION = 2 THEN _
  2508.               B$ = UP.TEMPLATE$ : _
  2509.               Z$ = "receive "
  2510.       CALL METAGSR (B$)
  2511.       CALL QTPUT ("Protocol     : "+PROTO.PROMPT$,1)   'KG120801
  2512.       CALL QTPUT ("Ready to " + Z$ + " ",0)
  2513.       IF BATCH.TRANSFER THEN _
  2514.          CALL QTPUT ("(BATCH)",1) : _
  2515.          CALL OPENWORK (NODE.WORK.FILE$) : _
  2516.          WHILE NOT EOF(2) : _
  2517.            CALL READANY : _
  2518.            CALL BRKFNAME (A$,Z$,Y$,X$,TRUE) : _
  2519.            CALL QTPUT ("   "+Y$+X$,1) : _
  2520.          WEND _
  2521.       ELSE CALL QTPUT (FILE.NAME.HOLD$,1)
  2522.       CALL XFRETURN
  2523.       END SUB
  2524. ' $SUBTITLE: 'XFRETURN - subroutine to exit as a private door.'
  2525. ' $PAGE
  2526. '
  2527. '  SUBROUTINE NAME    -- XFRETURN
  2528. '
  2529. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  2530. '                        TRANSFER.FUNCTION         = 1 DOWNLOAD FILE TO USER
  2531. '                                                  = 2 UPLOAD FILE TO RBBS-PC
  2532. '                                                  = 3 USER REGISTRATION PGM
  2533. '                        B$                        NAME OF FILE TO EXIT TO
  2534. '                        COM.PORT$                 NAME OF COMMUNICATIONS PORT
  2535. '                                                  TO BE USED BY KERMIT (COM1
  2536. '                                                  OR COM2)
  2537. '                        BPS                       = -1 FOR   300 BAUD
  2538. '                                                  = -2 FOR   450 BAUD
  2539. '                                                  = -3 FOR  1200 BAUD
  2540. '                                                  = -4 FOR  2400 BAUD
  2541. '                                                  = -5 FOR  4800 BAUD
  2542. '                                                  = -6 FOR  9600 BAUD
  2543. '                                                  = -7 FOR 19200 BAUD
  2544. '                        QMXFER.COM.FILE$          FILE TO TRANSFER CONTROL TO
  2545. '                                                  FOR YMODEM, IMODEM OR
  2546. '                                                  YMODEMG PROTOCOLS.
  2547. '
  2548. '  OUTPUT PARAMETERS  -- NONE
  2549. '
  2550. '  SUBROUTINE PURPOSE -- TO TRANSFER CONTROL TO ANOTHER PROGRAM
  2551. '
  2552.       SUB XFRETURN STATIC
  2553.       IF PRIVATE.DOOR THEN _
  2554.          GOTO 62630
  2555.       IF FAKE.XRPT THEN _
  2556.          CALL FAKEXRPT (FT$)
  2557.       IF ADVANCE.PROTO.WRITE THEN _
  2558.          CALL OPENOUTW ("XFER-"+NODE.ID$+".DEF") : _
  2559.          IF EC < 1 THEN _
  2560.             CALL PRNTWRKA (FILE.NAME$+",,"+FT$) : _
  2561.             CLOSE 2
  2562.       IF PROTO.METHOD$ = "S" THEN _
  2563.          GOTO 62629
  2564. 62628 X$ = LEFT$(B$,INSTR(B$+" "," ")-1)
  2565.       IF X$ = "" THEN _
  2566.          EXIT SUB
  2567.       CALL FINDIT (X$)
  2568.       IF NOT OK THEN _
  2569.          A$ = "Missing door program" : _
  2570.          CALL UPDTCALR (A$ + " " + X$,1) : _
  2571.          SNOOP = TRUE : _
  2572.          CALL LPRNT (A$,1) : _
  2573.          EXIT SUB
  2574.       A$(1) = DISK.FOR.DOS$ + _
  2575.               "COMMAND /C " + _
  2576.               B$
  2577.       A$(2) = RBBS.BAT$
  2578.       PRIVATE.DOOR = TRUE
  2579.       CALL QTPUT ("Exiting to External Program for File Transfer",1)
  2580.       LOCATE 25,1
  2581.       CALL LPRNT(LINE.FEED$,0)
  2582.       CALL RBBSEXIT (A$(),2)
  2583. 62629 CALL DELAYIT (8 + BPS)
  2584.       IF FOSSIL THEN _
  2585.          CALL FOSEXIT(COMPORT%) _
  2586.       ELSE CLOSE 3 : _
  2587.            OUT MODEM.CONTROL.REGISTER,INP(MODEM.CONTROL.REGISTER) OR 1
  2588.        CLOSE 2
  2589.       SHELL B$
  2590.       IF FOSSIL THEN _
  2591.         CALL FOSINIT(COMPORT%,RESULT%) : _
  2592.          IF RESULT% = -1 THEN _
  2593.            CALL PSCRN("ERROR INITIALIZING FOSSIL AFTER EXTERNAL PROTOCOL") : _
  2594.             SYSTEM
  2595.       CALL DELAYIT (2)
  2596. 62630 PARITY$ = MID$(",N,8,1,E,7,1",7 + 6 * EIGHT.BIT,6)
  2597.       IF LOCAL.USER THEN _
  2598.          GOTO 62631
  2599.       IF FOSSIL THEN _
  2600.          CALL SETBAUD _
  2601.       ELSE CALL OPENCOM(TALK.TO.MODEM.AT$,PARITY$)
  2602.       IF PRIVATE.DOOR THEN _
  2603.          CALL DELAYIT (7 + BPS) : _
  2604.          CALL QTPUT ("Reloading RBBS-PC.  Please be patient.",1)
  2605. 62631 CALL SKIPLINE (2)
  2606.       LOCATE 24,1
  2607. 62632 END SUB
  2608. ' $SUBTITLE: 'FAKEXRPT - subroutine to create fake xfer report'
  2609. ' $PAGE
  2610. '
  2611. '  SUBROUTINE NAME    --  FAKEXRPT
  2612. '
  2613. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2614. '                         FILE.NAME.HOLD$      FILE TO BE TRANSFERRED
  2615. '                         PROTO.USED$          PROTOCOL USED
  2616. '
  2617. '  OUTPUT PARAMETERS  --  WRITES OUT TRANSFER FILE REPORT
  2618. '
  2619. '  SUBROUTINE PURPOSE --  EXTERNAL PROTOCOL DRIVERS THAT DO NOT WRITE
  2620. '                         OUT A STANDARD TRANSFER REPORT MUST HAVE ONE
  2621. '                         PROVIDED IN ORDER FOR "DOORING" TO EXTERNAL
  2622. '                         PROTOCOLS TO WORK PROPERLY, SINCE THIS FILE
  2623. '                         IS READ UPON RETURNING FROM AN EXTERNAL PROTOCOL.
  2624. '
  2625. 62650 SUB FAKEXRPT (PROTO.USED$) STATIC
  2626.       CLOSE 2
  2627.       OPEN "O",2,"XFER-" + _
  2628.                  NODE.FILE.ID$ + _
  2629.                  ".DEF"
  2630.       PRINT #2,FILE.NAME$
  2631.       PRINT #2,
  2632.       PRINT #2,PROTO.USED$
  2633.       PRINT #2,"S"
  2634.       CLOSE 2
  2635.       END SUB
  2636. ' $SUBTITLE: 'SETEXPERT - subroutine to adjust for expert change'
  2637. ' $PAGE
  2638. '
  2639. '  SUBROUTINE NAME    --  SETEXPERT
  2640. '
  2641. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2642. '                         EXPERT.USER          WHETHER IS AN EXPERT
  2643. '
  2644. '  OUTPUT PARAMETERS  --  MORE.PROMPT$         Pause prompt
  2645. '                         PRESS.ENTER$         Prompt to press enter
  2646. '
  2647. '  SUBROUTINE PURPOSE --  EXTERNAL PROTOCOL DRIVERS THAT DO NOT WRITE
  2648. '                         OUT A STANDARD TRANSFER REPORT MUST HAVE ONE
  2649. '                         PROVIDED IN ORDER FOR "DOORING" TO EXTERNAL
  2650. '                         PROTOCOLS TO WORK PROPERLY, SINCE THIS FILE
  2651. '                         IS READ UPON RETURNING FROM AN EXTERNAL PROTOCOL.
  2652. '
  2653. 62660 SUB SETEXPERT STATIC
  2654.       IF EXPERT.USER THEN _
  2655.          MORE.PROMPT$ = "More <[Y],N,C,A" : _
  2656.          PRESS.ENTER$ = PRESS.ENTER.EXPERT$ : _
  2657.          EXIT SUB
  2658.       MORE.PROMPT$ = "More [Y]es,N)o,C)ontinuous,A)bort"
  2659.       PRESS.ENTER$ = PRESS.ENTER.NOVICE$
  2660.       END SUB
  2661.       SUB NEWPASWRD (PRMPT$,DISALLOW.SPACES) STATIC                  ' KG101501
  2662. 62670 A$ = PRMPT$                                                    ' KG101501
  2663.       HIDDEN = TRUE                                                  ' KG101501
  2664.       SUBROUTINE.PARAMETER = 1                                       ' KG101501
  2665.       CALL TGET                                                      ' KG101501
  2666.       HIDDEN = FALSE                                                 ' KG101501
  2667.       IF SUBROUTINE.PARAMETER < 0 OR Q = 0 THEN _                    ' KG101501
  2668.          EXIT SUB                                                    ' KG101501
  2669.       IF LEN(B$) > 15 THEN _                                         ' KG101501
  2670.          CALL QTPUT ("15 chars max",1) : _                           ' KG101501
  2671.          GOTO 62670                                                  ' KG101501
  2672.       IF INSTR(B$,";") > 0 THEN _                                    ' KG101501
  2673.          CALL QTPUT ("Cannot use ';'",1) : _                         ' KG101501
  2674.          GOTO 62670                                                  ' KG101501
  2675.       IF DISALLOW.SPACES THEN _                                      ' KG101501
  2676.          IF B$ = SPACE$(LEN(B$)) THEN _                              ' KG101501
  2677.             CALL QTPUT ("Not all blanks",1) : _                      ' KG101501
  2678.             GOTO 62670                                               ' KG101501
  2679.       CALL ALLCAPS (B$)                                              ' KG101501
  2680.       Z$ = B$                                                        ' KG101501
  2681.       END SUB                                                        ' KG101501
  2682. ' $SUBTITLE: 'TIMEDOUT - subroutine to exit based on time of day'
  2683. ' $PAGE
  2684. '
  2685. '  SUBROUTINE NAME    --  TIMEDOUT
  2686. '
  2687. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2688. '                         RCTTY.BAT$
  2689. '                         NODE.RECORD.INDEX
  2690. '                         MESSAGE.RECORD$
  2691. '                         MODEM.INIT.BAUD$
  2692. '                         MODEM.GO.OFFHOOK.COMMADN$
  2693. '
  2694. '  OUTPUT PARAMETERS  --  NONE
  2695. '
  2696. '  SUBROUTINE PURPOSE --  WHEN RBBS-PC IS TO EXIT TO DOS AT A SPECIFIC TIME OF
  2697. '                         DAY, THIS ROUTINE WRITES OUT TO THE FILE SPECIFIED
  2698. '                         IN "RCTTY.BAT$" THE ONE-LINE ENTRY:
  2699. '                                    RBBSTIMx.BAT
  2700. '                         WHERE "x" IS EQUAL TO THE NODE ID.
  2701. '
  2702. 63000 SUB TIMEDOUT STATIC
  2703.       FIELD #1,128 AS MESSAGE.RECORD$
  2704.       SUBROUTINE.PARAMETER = 3
  2705.       CALL FILELOCK
  2706.       GET 1,NODE.RECORD.INDEX
  2707.       X$ = DATE$
  2708.       CALL CSTRDATE (X$,Y$)
  2709.       MID$(MESSAGE.RECORD$,77,2) = Y$
  2710.       MID$(MESSAGE.RECORD$,86,5) = LEFT$(TIME$,5)
  2711.       PUT 1,NODE.RECORD.INDEX
  2712.       SUBROUTINE.PARAMETER = 2
  2713.       CALL FILELOCK
  2714.       CLOSE 2
  2715.       CALL BRKFNAME(CALLERS.FILE$,X$,Y$,Z$,TRUE)
  2716.       FILE.NAME$ = X$ + "RBBS" + NODE.FILE.ID$ + "TM.DEF"
  2717.       OPEN "O",2,FILE.NAME$
  2718.       PRINT #2,MID$(FILE.NAME$,3,7)
  2719.       CLOSE 2
  2720.       IF LOCAL.USER.MODE THEN _
  2721.          EXIT SUB
  2722.       IF SUBROUTINE.PARAMETER <> 7 THEN _
  2723.          SUBROUTINE.PARAMETER = 4 : _
  2724.          CALL FILELOCK : _
  2725.          CALL OPENCOM(MODEM.INIT.BAUD$,",N,8,1")
  2726.       CALL MODEMPUT (MODEM.GO.OFFHOOK.COMMAND$)
  2727.       IF MULTI.LINK.PRESENT <> 0 THEN _
  2728.          CALL DELAYIT (3)
  2729.       END SUB
  2730. ' $SUBTITLE: 'ASKUSERS - subroutine to get registration information'
  2731. ' $PAGE
  2732. '
  2733. '  SUBROUTINE NAME    --  ASKUSERS  (WRITTEN BY JON MARTIN)
  2734. '
  2735. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  2736. '                         FILE.NAME$           NAME OF THE FILE CONTAINING THE
  2737. '                                              SCRIPT TO BE USED WHEN ASKING
  2738. '                                              THE USER QUESTIONS.
  2739. '                         ACTIVE.USER.NAME$    NAME OF THE CURRENT USER
  2740. '                         USER.SECURITY.LEVEL  USER'S SECURITY
  2741. '                         UPPER.CASE           SET IF USER NEEDS UPPERCASE
  2742. '
  2743. '  OUTPUT PARAMETERS  --  WRITE THE USER'S RESPONSES TO THE QUESTIONS TO THE
  2744. '                         FILE NAME SPECIFIED AS THE FIRST PARAMETER IN THE
  2745. '                         FIRST RECORD OF THE FILE CONTAINING THE SCRIPT TO
  2746. '                         BE USED.
  2747. '                         USER.SECURITY.LEVEL  CAN BE RAISED OR LOWERED
  2748. '
  2749. '  SUBROUTINE PURPOSE --  PROVIDES A SOPHISTCATED, SCRIPT DRIVEN MECHANISM BY
  2750. '                         WHICH A SYSOP CAN SOLICIT INFORMATION FROM NEW USERS
  2751. '                         (VIA A SCRIPT THAT REQUESTS REGISTRATION INFORMATION
  2752. '                         AND WHICH CAN UPPER OR LOWER HIS DEFAULT SECURITY
  2753. '                         LEVEL BASED ON THE RESPONSES) OR ASK A QUESTIONS OF
  2754. '                         WHEN THE USER LOGS OFF.  THE FORMER OCCURS IF THE
  2755. '                         FILE "RBBS-REG.DEF" CONTAINING THE REGISTRATION
  2756. '                         SCRIPT EXISTS ON THE SAME DRIVE AS THE "WELCOME".
  2757. '                         THE LATER EXISTS IF THE FILE "EPILOG.DEF" EXISTS ON
  2758. '                         THE SAME DRIVE AS THE "WELCOME".
  2759. '
  2760.       SUB ASKUSERS STATIC
  2761. '
  2762. ' *
  2763. ' *  LOAD SCRIPT CONTAING THE QUESTIONS INTO THE A$ DIMENSION                 *
  2764. ' *
  2765. '
  2766. 64005 CHAT.AVAILABLE = FALSE
  2767.       QUESTIONNAIRE.CHAIN = FALSE
  2768.       CALL OPENWORK (FILE.NAME$)
  2769.       IF EC > 0 THEN _                                               ' KG102403
  2770.          EXIT SUB                                                    ' KG102403
  2771.       CALL READPARMS (A$(),2,1)                                      ' KG102403
  2772.       IF EC > 0 THEN _                                               ' KG102403
  2773.          EXIT SUB                                                    ' KG102403
  2774.       APPEND.FILE.NAME$ = A$(1)                                      ' KG102403
  2775.       MAXIMUM.SECURITY.LEVEL = VAL(A$(2))                            ' KG102403
  2776. '
  2777. ' *
  2778. ' *  THE FIRST RECORD OF THE SCRIPT FILE CONTAINS TWO PARAMETERS:             *
  2779. ' *   1.  THE NAME OF THE FILE TO APPEND THE ANSWERS TO.                      *
  2780. ' *   2.  THE MAXIMUM SECURITY LEVEL THE + COMMAND CAN RAISE A USER SECURITY  *
  2781. ' *
  2782.       SCRIPT.INDEX = 1
  2783.       A$(SCRIPT.INDEX) = ACTIVE.USER.NAME$ + _
  2784.                          " " + _
  2785.                          DATE$ + _
  2786.                          " " + _
  2787.                          TIME$
  2788. 64010 IF EOF(2) OR SCRIPT.INDEX > 255 THEN _
  2789.          GOTO 64100
  2790.       SCRIPT.INDEX = SCRIPT.INDEX + 1
  2791.       LINE INPUT #2,A$(SCRIPT.INDEX)
  2792.       IF UPPER.CASE THEN _
  2793.          CALL ALLCAPS (A$(SCRIPT.INDEX))
  2794.       IF LEFT$(A$(SCRIPT.INDEX),1) = "?" THEN _
  2795.          SCRIPT.INDEX = SCRIPT.INDEX + 1 : _
  2796.          A$(SCRIPT.INDEX) = "!"
  2797.       GOTO 64010
  2798. '
  2799. ' *
  2800. ' *  PROCESS QUESTIONS IN THE SCRIPT AS FOLLOWS:                              *
  2801. ' *                                                                           *
  2802. ' * FIRST COLUMN     MEANING                                                  *
  2803. ' *      :        THIS LINE IS A LABEL THAT MAY BE BRANCHED TO                *
  2804. ' *      !        THIS MEANS THIS IS AN ANSWER                                *
  2805. ' *      >        THIS IS A "GOTO" COMMAND TO ONE OF THE LABELS               *
  2806. ' *      *        THIS MEANS THE LINE IS A MESSAGE TO BE WRITTEN TO THE USER  *
  2807. ' *      ?        THIS MEANS THIS IS A QUESTION FOR THE USER                  *
  2808. ' *      =        THIS MEANS THAT THIS LINE CONTAINS DECISION CRITERIA        *
  2809. ' *      -        THIS MEANS TO LOWER THE USER'S SECURITY LEVEL               *
  2810. ' *      +        THIS MEANS TO RAISE THE USER'S SECURITY LEVEL               *
  2811. ' *      @        THIS MEANS TO ABORT THE QUESTIONNAIRE DO NOT WRITE OUT      *
  2812. ' *      &        THIS MEANS TO CHAIN TO ANOTHER QUESTIONNAIRE                *
  2813. ' *
  2814. '
  2815. 64100 SCRIPT.MAX = SCRIPT.INDEX
  2816.       SCRIPT.INDEX = 1
  2817. 64110 CALL CARRIER
  2818.       IF SUBROUTINE.PARAMETER = -1 THEN _
  2819.          GOTO 64115
  2820.       SCRIPT.INDEX = SCRIPT.INDEX + 1
  2821.       IF SCRIPT.INDEX > SCRIPT.MAX THEN _
  2822.          GOTO 64400
  2823.       IF LEFT$(A$(SCRIPT.INDEX),1) = ":" THEN _         ' LABEL
  2824.          GOTO 64110
  2825.       IF LEFT$(A$(SCRIPT.INDEX),1) = "!" THEN _         ' ANSWER
  2826.          GOTO 64110
  2827.       IF LEFT$(A$(SCRIPT.INDEX),1) = "@" THEN _         ' ABORT
  2828.          QUESTIONNAIRE.ABORTED = TRUE : _
  2829.          GOTO 64510
  2830.       IF LEFT$(A$(SCRIPT.INDEX),1) = ">" THEN _         ' GOTO
  2831.          BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),2) : _
  2832.          GOSUB 64200 : _
  2833.          IF SUBROUTINE.PARAMETER = -1 THEN _
  2834.             GOTO 64510 _
  2835.          ELSE GOTO 64110
  2836.       IF LEFT$(A$(SCRIPT.INDEX),1) = "*" THEN _         ' MESSAGE
  2837.          A$ = MID$(A$(SCRIPT.INDEX),2) : _
  2838.          SUBROUTINE.PARAMETER = 5 : _
  2839.          CALL TPUT : _
  2840.          IF SUBROUTINE.PARAMETER = -1 THEN _
  2841.             GOTO 64510 _
  2842.          ELSE GOTO 64110
  2843. 64113 IF LEFT$(A$(SCRIPT.INDEX),1) = "?" THEN _         ' QUESTION
  2844.          A$ = MID$(A$(SCRIPT.INDEX),2) : _
  2845.          SUBROUTINE.PARAMETER = 1 : _
  2846.          CALL TGET : _
  2847.          IF SUBROUTINE.PARAMETER = -1 THEN _
  2848.             GOTO 64510 _
  2849.          ELSE IF Q = 0 THEN _
  2850.                  GOTO 64113 _
  2851.               ELSE A$(SCRIPT.INDEX + 1) = "!" + _
  2852.                                           B$ : _
  2853.                    GOTO 64110
  2854.       IF LEFT$(A$(SCRIPT.INDEX),2) = "=#" THEN _                     ' NUMERIC
  2855.          GOSUB 64350 : _
  2856.          GOTO 64110
  2857.       IF LEFT$(A$(SCRIPT.INDEX),1) = "=" THEN _         ' DECISION
  2858.          GOSUB 64300 : _
  2859.          IF SUBROUTINE.PARAMETER = -1 THEN _
  2860.             GOTO 64510 _
  2861.          ELSE GOTO 64110
  2862.       IF LEFT$(A$(SCRIPT.INDEX),1) = "-" THEN _         ' LOWER
  2863.          ADJUSTED.SECURITY = -1 : _
  2864.          USER.SECURITY.LEVEL = USER.SECURITY.LEVEL - _
  2865.                                VAL(MID$(A$(SCRIPT.INDEX),2,5)) : _
  2866.          USER.SECURITY.SAVE = USER.SECURITY.LEVEL : _
  2867.          GOTO 64110
  2868.       IF LEFT$(A$(SCRIPT.INDEX),1) = "+" THEN _         ' RAISE
  2869.          IF USER.SECURITY.LEVEL + VAL(MID$(A$(SCRIPT.INDEX),2,5)) _
  2870.             <= MAXIMUM.SECURITY.LEVEL THEN _
  2871.                ADJUSTED.SECURITY = -1 : _
  2872.                USER.SECURITY.SAVE = USER.SECURITY.LEVEL : _
  2873.                USER.SECURITY.LEVEL = USER.SECURITY.LEVEL + _
  2874.                                VAL(MID$(A$(SCRIPT.INDEX),2,5))
  2875.       IF LEFT$(A$(SCRIPT.INDEX),1) = "+" THEN _
  2876.          GOTO 64110
  2877.       IF LEFT$(A$(SCRIPT.INDEX),1) = "&" THEN _
  2878.          QUESTIONNAIRE.CHAIN = TRUE : _
  2879.          FILE.NAME.HOLD$ = MID$(A$(SCRIPT.INDEX),2) : _
  2880.          GOTO 64110
  2881.       A$ = "Invalid line.  Column 1 is <" + LEFT$(A$(SCRIPT.INDEX),1)+">.  Must be: * ? = + - > @ &"
  2882.       SUBROUTINE.PARAMETER = 5
  2883.       CALL TPUT
  2884. 64115 GOTO 64510
  2885. '
  2886. ' *
  2887. ' *  SEARCH FOR GOTO LABEL                                                    *
  2888. ' *
  2889. '
  2890. 64200 SCRIPT.INDEX = 1
  2891. 64210 SCRIPT.INDEX = SCRIPT.INDEX + 1
  2892.       IF SCRIPT.INDEX > SCRIPT.MAX THEN _
  2893.          A$ = BRANCH.LABEL$ + _
  2894.               " not found!" : _
  2895.          SUBROUTINE.PARAMETER = 5 : _
  2896.          CALL TPUT : _
  2897.          IF SUBROUTINE.PARAMETER = -1 THEN _
  2898.             RETURN _
  2899.          ELSE GOTO 64115
  2900.       IF LEFT$(A$(SCRIPT.INDEX),1) <> ":" THEN _
  2901.          GOTO 64210
  2902.       IF MID$(A$(SCRIPT.INDEX),2) <> BRANCH.LABEL$ THEN _
  2903.          GOTO 64210
  2904.       RETURN
  2905. '
  2906. ' *
  2907. ' *  DETERMINE BRANCH LOGIC                                                   *
  2908. ' *
  2909. '
  2910. 64300 CURRENT.EQUALS = 1
  2911.       Z$ = RIGHT$(A$(SCRIPT.INDEX - 1),1)
  2912.       CALL ALLCAPS (Z$)
  2913. 64310 NEXT.EQUALS = INSTR(CURRENT.EQUALS + 1, A$(SCRIPT.INDEX),"=")
  2914.       IF NEXT.EQUALS = 0 THEN _
  2915.          BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2) : _
  2916.          GOTO 64320
  2917.       IF Z$ <> _
  2918.          MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 1,1) THEN  _
  2919.          CURRENT.EQUALS = NEXT.EQUALS : _
  2920.          GOTO 64310
  2921.       BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2,NEXT.EQUALS-(CURRENT.EQUALS + 2))
  2922. 64320 GOSUB 64200
  2923.       RETURN
  2924. '
  2925. ' *
  2926. ' *  DETERMINE NUMERIC BRANCH LOGIC                                           *
  2927. ' *
  2928. '
  2929. 64350 CURRENT.EQUALS = 1
  2930. 64360 NEXT.EQUALS = INSTR(CURRENT.EQUALS + 1, A$(SCRIPT.INDEX),"=")
  2931.       IF NEXT.EQUALS = 0 THEN _
  2932.          BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2) : _
  2933.          GOTO 64380
  2934.       NUMERIC = TRUE
  2935.       LOOP.INDEX = 2
  2936.       WHILE LOOP.INDEX < LEN(A$(SCRIPT.INDEX - 1)) +1
  2937.          IF INSTR("()1234567890- ",MID$(A$(SCRIPT.INDEX - 1),LOOP.INDEX,1)) THEN _
  2938.             GOTO 64370
  2939.          NUMERIC = FALSE
  2940. 64370    LOOP.INDEX = LOOP.INDEX + 1
  2941.       WEND
  2942.       IF NOT NUMERIC THEN _
  2943.          CURRENT.EQUALS = NEXT.EQUALS : _
  2944.          GOTO 64360
  2945.       BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2,NEXT.EQUALS-(CURRENT.EQUALS + 2))
  2946. 64380 GOSUB 64200
  2947.       RETURN
  2948. '
  2949. ' *
  2950. ' *  WRITE RESPONSES TO DESIGNATED FILE                                       *
  2951. ' *
  2952. '
  2953. 64400 SCRIPT.INDEX = 0
  2954.       EC = 0
  2955.       SUBROUTINE.PARAMETER = 9
  2956.       FILE.NAME$ = APPEND.FILE.NAME$
  2957.       EN$ = APPEND.FILE.NAME$
  2958.       CALL FILELOCK
  2959.       CALL OPENWRKA (APPEND.FILE.NAME$)
  2960.       IF EC <> 0 THEN _
  2961.          A$ = "Fatal Error in script!" : _
  2962.          SUBROUTINE.PARAMETER = 5 : _
  2963.          CALL TPUT : _
  2964.          GOTO 64500
  2965. 64410 SCRIPT.INDEX = SCRIPT.INDEX + 1
  2966.       IF SCRIPT.INDEX > SCRIPT.MAX THEN _
  2967.          GOTO 64500
  2968.       IF LEFT$(A$(SCRIPT.INDEX),1) = ":" THEN _
  2969.          QUESTION.SAVE$ = MID$(A$(SCRIPT.INDEX),2) : _
  2970.          GOTO 64410
  2971.       IF LEFT$(A$(SCRIPT.INDEX),1) = "!" AND _
  2972.          LEN(A$(SCRIPT.INDEX)) < 2 THEN _
  2973.          GOTO 64410
  2974.       IF LEFT$(A$(SCRIPT.INDEX),1) = "!" THEN _
  2975.          CALL PRNTWRKA (QUESTION.SAVE$) : _
  2976.          CALL PRNTWRKA (MID$(A$(SCRIPT.INDEX),2))
  2977.       IF SCRIPT.INDEX = 1 AND _
  2978.          NOT QUESTIONNAIRE.CHAIN.STARTED THEN _
  2979.          CALL PRNTWRKA (A$(SCRIPT.INDEX))
  2980.       IF EC <> 0 THEN _
  2981.          A$ = "Unrecoverable failure in script!" : _
  2982.          SUBROUTINE.PARAMETER = 5 : _
  2983.          CALL TPUT : _
  2984.          GOTO 64500
  2985.       GOTO 64410
  2986. 64500 CLOSE 2
  2987.       SUBROUTINE.PARAMETER = 10
  2988.       CALL FILELOCK
  2989.       CALL CARRIER
  2990.       IF QUESTIONNAIRE.CHAIN THEN _
  2991.          QUESTIONNAIRE.CHAIN.STARTED = TRUE : _
  2992.          FILE.NAME$ = FILE.NAME.HOLD$ : _
  2993.          GOTO 64005
  2994. 64510 CHAT.AVAILABLE = (INSTR("MUF",ACTIVE.MENU$) > 0)
  2995.       END SUB
  2996. ' $SUBTITLE: 'VIEWARC - subroutine to display .ARC contents'
  2997. ' $PAGE
  2998. '
  2999. '  SUBROUTINE NAME    --  VIEWARC  (Written by Jon Martin)
  3000. '
  3001. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  3002. '                         FILE.NAME$           NAME OF THE ARC FILE TO BE
  3003. '                                              VIEWED.
  3004. '
  3005. '  OUTPUT PARAMETERS  --  NONE
  3006. '
  3007. '  SUBROUTINE PURPOSE --  PROVIDES A MECHANISM TO PROVIDE USERS WITH THE
  3008. '                         CONTENTS OF AN ARC FILE PRIOR TO DOWNLOADING.
  3009.       SUB VIEWARC STATIC
  3010.  64600  CLOSE 2 
  3011.          IF TURBO.RBBS THEN _
  3012.           RETCODE% = 0
  3013. ' ***** MODS to ARCVIEW to Allow ZOO / PAK / DCW files to be viewd ****
  3014. '    added ZIP support 02/18/89
  3015. '
  3016. IF LAST.EXT$ = "ZIP" THEN _
  3017.    FILNAME$ = LIBRARY.ARCHIVE.PATH$+"PKUNZIP.EXE" _    'PE/03/28/89
  3018. ELSE _
  3019.   FILNAME$ = LIBRARY.ARCHIVE.PATH$+"ARCVIEW.COM"       'PE/03/28/89
  3020.  CALL FINDIT (FILNAME$)
  3021.  IF NOT OK THEN _
  3022.   CALL QTPUT(" Missing Viewarc Utility...Please tell Sysop " ,1) : _
  3023.  EXIT SUB
  3024. '
  3025. CALL QTPUT ("Creating View file, One Moment Please.... ",1)
  3026. IF LAST.EXT$ = "ZIP" THEN _
  3027.  STOP.INTERRUPTS = TRUE : _
  3028.    SHOWARC$ = LIBRARY.ARCHIVE.PATH$+"PKUNZIP.EXE -v "_
  3029.  ELSE _
  3030.     SHOWARC$ = LIBRARY.ARCHIVE.PATH$+"ARCVIEW.COM "
  3031. '
  3032. SHOWARC$ = SHOWARC$ +FILE.NAME$ + ">" + ARC.WORK$
  3033.  SHELL SHOWARC$
  3034.  CALL BUFFILE (ARC.WORK$,X)
  3035.  EXIT SUB
  3036. ' *** Code Below is orig RBBS 17C ***********
  3037. '64600  CLOSE 2
  3038. '        IF TURBO.RBBS THEN _
  3039. '         RETCODE% = 0 : _
  3040. '         CALL ARCV (ARC.WORK$,FILE.NAME$,RETCODE%) : _
  3041. '         CALL BUFFILE (ARC.WORK$,X) : _
  3042. '         EXIT SUB
  3043. '************ end of ASM routines for VIEWARC ****************
  3044.       IF SHARE.IT THEN _                                             ' KG102402
  3045.          OPEN FILE.NAME$ FOR RANDOM SHARED AS #2 LEN=1 _             ' KG102402
  3046.       ELSE OPEN "R",2,FILE.NAME$,1                                   ' KG102402
  3047.       FIELD 2,1 AS CHAR$
  3048.       BYTE.POINTER! = 1
  3049.       ARC.END! = LOF(2)
  3050. 64605 IF BYTE.POINTER! > ARC.END! THEN _
  3051.          GOTO 64620
  3052.       GET 2,BYTE.POINTER!
  3053.       IF CHAR$ <> CHR$(26) THEN _
  3054.          GOTO 64620
  3055.       BYTE.POINTER! = BYTE.POINTER! + 1
  3056.       GET 2,BYTE.POINTER!
  3057.       IF CHAR$ = CHR$(0) THEN _
  3058.          GOTO 64620
  3059.       ARCED.NAME$ = ""
  3060.       FOR X = 1 TO 12
  3061.          GET 2,BYTE.POINTER! + X
  3062.          IF CHAR$ < CHR$(40) THEN _
  3063.             GOTO 64610
  3064.          ARCED.NAME$ = ARCED.NAME$ + _
  3065.                        CHAR$
  3066.       NEXT
  3067. 64610 A$ = ARCED.NAME$
  3068.       BYTE.POINTER! = BYTE.POINTER! + 14
  3069.       GOSUB 64630
  3070.       TOTAL.BYTES# = WORK.BYTES#
  3071.       BYTE.POINTER! = BYTE.POINTER! + 10
  3072.       GOSUB 64630
  3073.       FINAL.BYTES# = WORK.BYTES#
  3074.       A$ = A$ + _
  3075.            SPACE$(20 - LEN(ARCED.NAME$) - LEN(STR$(FINAL.BYTES#))) + _
  3076.            STR$(FINAL.BYTES#) + _
  3077.            " bytes."
  3078.       CALL QTPUT(A$,1)
  3079.       BYTE.POINTER! = BYTE.POINTER! + TOTAL.BYTES# + 4
  3080.       GOTO 64605
  3081. 64620 CLOSE 2
  3082.       SUBROUTINE.PARAMETER = 0
  3083.       CALL CARRIER
  3084.       A$ = ""
  3085.       EXIT SUB
  3086. 64630 FACTOR# = 1#
  3087.       WORK.BYTES# = 0
  3088.       FOR X = 0 TO 3
  3089.          GET 2,BYTE.POINTER! + X
  3090.          WORK.BYTES# = WORK.BYTES# + FACTOR# * ASC(CHAR$)
  3091.          FACTOR# = FACTOR# * 256#
  3092.       NEXT
  3093.       RETURN
  3094.       END SUB
  3095.